highlight.el - simple highlighting commands

[Drew Adams]

;;; highlight.el --- Simple highlighting commands.
;; 
;; Emacs Lisp Archive Entry
;; Filename: highlight.el
;; Description: Simple highlighting commands.
;; Author: David Brennan, address@hidden
;;      Drew Adams
;; Maintainer: Drew Adams
;; Copyright (C) 1996-2001, Drew Adams, all rights reserved.
;; Copyright 1992, Dave Brennan
;; Created: Wed Oct 11 15:07:46 1995
;; Version: $Id: highlight.el,v 1.5 2001/01/08 23:18:59 dadams Exp $
;; Last-Updated: Mon Jan  8 15:18:45 2001
;;           By: dadams
;;     Update #: 414
;; Keywords: faces, help, local
;; Compatibility: GNU Emacs 20.x
;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 
;;; Commentary:
;;
;;    Simple highlighting commands.
;; 
;;  Main new functions defined here:
;;
;;    `highlight', `highlight-regexp', `highlight-regexp-region',
;;    `highlight-region', `highlight-single-quotations',
;;    `mouse-face-each-line', `mouse-face-following-lines',
;;    `unhighlight-region'.
;;
;;  New user option (variable) defined here:
;;
;;    `max-highlight-w-o-warning'.
;;
;;  Other variable defined here: `highlight-last-regexp'.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 
;;; Change log:
;; 
;; RCS $Log: highlight.el,v $
;; RCS Revision 1.5  2001/01/08 23:18:59  dadams
;; RCS Adapted file header for Emacs Lisp Archive.
;; RCS
;; RCS Revision 1.4  2001/01/03 17:37:42  dadams
;; RCS *** empty log message ***
;; RCS
;; RCS Revision 1.3  2001/01/03 00:24:15  dadams
;; RCS *** empty log message ***
;; RCS
;; RCS Revision 1.2  2000/11/28 20:20:57  dadams
;; RCS Optional require's via 3rd arg=t now.
;; RCS
;; RCS Revision 1.1  2000/09/14 17:20:24  dadams
;; RCS Initial revision
;; RCS
; Revision 1.2  1999/04/13  14:01:03  dadams
; *** empty log message ***
;
; Revision 1.20  1996/06/06  14:01:10  dadams
; Update of file dependency comments (e.g. "Autoloaded from...").
;
; Revision 1.19  1996/04/26  09:32:00  dadams
; Put escaped newlines on long-line strings.
;
; Revision 1.18  1996/04/25  13:48:13  dadams
; 1. Added highlight-single-quotations.
; 2. highlight-regexp, highlight-regexp-region: Added new optional arg NTH.
;
; Revision 1.17  1996/04/25  09:34:55  dadams
; Added mouse-face-following-lines.
;
; Revision 1.16  1996/04/04  14:29:14  dadams
; 1. highlight: Removed RAW-PREFIX, DISPLAY-MSGS args.  Made PREFIX optional.
;    Set current-prefix-arg to nil so called fns don't use it as mouse-p.
; 2. highlight-regexp, highlight-regexp-region: Added MOUSE-P arg.
;
; Revision 1.15  1996/03/08  12:17:36  dadams
; 1. Copyright.
; 2. drew-faces.el -> std-faces.el, drew-windows.el -> frame-fns.el.
;
; Revision 1.14  1996/02/27  10:33:08  dadams
; Added mouse-face-each-line.
;
; Revision 1.13  1996/02/26  14:09:44  dadams
; unhighlight-region: Added new arg MOUSE-P.
;
; Revision 1.12  1996/02/13  07:08:02  dadams
; Removed highlight-apropos-info to help.el.
;
; Revision 1.11  1996/02/12  15:20:38  dadams
; 1. highlight-region: Added optional arg MOUSE-P.
; 2. highlight-apropos-info: Add mouse-face to each entry line.
;
; Revision 1.10  1996/02/12  09:59:43  dadams
; Updated header keywords (for finder).
;
; Revision 1.9  1996/02/06  10:59:42  dadams
; Put variable-interactive property on appropriate user option vars.
;
; Revision 1.8  1996/02/01  09:41:09  dadams
; highlight: Just call subfns interactively.
; highlight-region, highlight-regexp ,highlight-regexp-region: 
;   Use read-face-name.
;
; Revision 1.7  1996/01/15  08:03:04  dadams
; highlight-apropos-info: local-syntax-table -> unwind-protect,set-syntax-table
;
; Revision 1.6  1996/01/08  14:01:06  dadams
; highlight-regexp, highlight-regexp-region: message -> display-in-minibuffer.
; Require drew-faces.el.
;
; Revision 1.5  1995/12/28  15:33:14  dadams
; 1. Added ;;;###autoloads.
; 2. Removed require of drew-windows.el, since autoloaded.
;
; Revision 1.4  1995/12/04  16:39:26  dadams
; dark-magenta-foreground-face -> magenta4-foreground-face
;
; Revision 1.3  1995/11/22  15:07:46  dadams
; drew-util-19.el -> drew-windows.el
;
; Revision 1.2  1995/11/09  14:47:06  dadams
; highlight-region: FACE arg is optional.
;
; Revision 1.1  1995/10/16  11:29:25  dadams
; Initial revision
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 
;;; Code: 

(require 'cl) ;; unless, when

(require 'frame-fns nil t) ;; (no error if not found): flash-ding
(require 'strings nil t) ;; (no error if not found): display-in-minibuffer
(require 'faces+ nil t) ;; (no error if not found): read-face-name


(provide 'highlight)

;;;;;;;;;;;;;;;;

;;;###autoload
(defvar max-highlight-w-o-warning 100000
  "*Max size of region to highlight without confirmation.")
(put 'max-highlight-w-o-warning 'variable-interactive
     "sMax number of chars in region to highlight without confirmation: ")

;;;###autoload
(defvar highlight-last-regexp nil "The last regexp highlighted.")


(defsubst highlight-single-quotations (&optional face)
  "Highlight single-quoted text (e.g commands and keys between `'s).
Optional arg FACE is the face (default: `blue-foreground-face')."
  (interactive)
  (highlight-regexp "`\\([^']+\\)'"
                    (or face
                        (if (boundp 'blue-foreground-face)
                            blue-foreground-face
                          'highlight))
                    nil nil 1))

;;;###autoload
(defun highlight (&optional prefix)
  "Highlight region, regexp (PREFIX +), or unhighlight region (PREFIX -).
PREFIX arg: 0,+ => highlight-regexp-region
              - => unhighlight-region
            nil => highlight-region"
  (interactive "P")
  (setq current-prefix-arg nil)         ; No mouse-p.
  (if prefix
      (if (natnump (prefix-numeric-value prefix))
          (call-interactively 'highlight-regexp-region)
        (save-excursion (call-interactively 'unhighlight-region)))
    (call-interactively 'highlight-region)
    (message "Highlighting region ... done.  %s"
             (substitute-command-keys
              "`\\[negative-argument] \\[highlight]' to remove all \
highlighting in region."))))

;;;###autoload
(defun unhighlight-region (reg-start reg-end &optional where mouse-p)
  "Remove faces in region.
Required arguments:
 REG-START, REG-END: beginning and end of the region to unhighlight.
Optional 3rd argument WHERE:
 If a string, it is inserted in progress message.
 If otherwise non-nil, no progress message is displayed.
Optional 4th arg MOUSE-P non-nil => Use `mouse-face' property, not `face'.
Interactively, MOUSE-P is provided by the prefix arg."
  (interactive (list (region-beginning) (region-end) "in region "
                     current-prefix-arg))
  (setq where (or where ""))
  (when (stringp where) (message (format "Removing highlighting %s..." where)))
  (let ((read-only-p buffer-read-only)
        (modified-p (buffer-modified-p)))
    (setq buffer-read-only nil)
    (remove-text-properties reg-start reg-end
                            (if mouse-p '(mouse-face) '(face)))
    (setq buffer-read-only read-only-p)
    (set-buffer-modified-p modified-p))
  (when (stringp where)
    (message (format "Removing highlighting %s... done." where))))

;;;###autoload
(defun highlight-region (start end &optional face mouse-p)
  "Highlight region between START and END with FACE (default: `highlight').
Optional arg MOUSE-P non-nil => Use `mouse-face' property, not `face'.
Interactively, MOUSE-P is provided by the prefix arg."
  (interactive
   (list (region-beginning) (region-end)
         (read-face-name "Use highlighting face: ")
         current-prefix-arg))
  (setq face (or face 'highlight))
  (let ((read-only buffer-read-only)
        (modified-p (buffer-modified-p)))
    (setq buffer-read-only nil)
    (put-text-property start end (if mouse-p 'mouse-face 'face) face)
    (setq buffer-read-only read-only)
    (set-buffer-modified-p modified-p))
  ;; Prevent `lazy-lock-mode' from unhighlighting.
  (when (and (fboundp 'lazy-lock-after-fontify-buffer) lazy-lock-mode)
    (lazy-lock-after-fontify-buffer)))

;;;###autoload
(defun highlight-regexp (regexp face &optional display-msgs mouse-p nth)
  "Highlight text after cursor that matches REGEXP, with face FACE.
Default face is `highlight'.
Optional 3rd arg DISPLAY-MSGS non-nil =>
         Display \"Highlighting ... \" progress message.
Optional 4th arg MOUSE-P non-nil => `mouse-face' property, not `face'.
         Interactively, MOUSE-P is provided by the prefix arg.
Optional 5th arg NTH determines which regexp subgroup is highlighted.
         If NTH is nil or 0, the entire regexp is highlighted.
         Otherwise, the NTH regexp subgroup (\"\\\\( ... \\\\)\"
         expression) is highlighted.  (Not available interactively.)"
  (interactive
   (list (read-string "Regexp to highlight after cursor: "
                      highlight-last-regexp)
         (read-face-name "Use highlighting face: ")
         'display-msgs
         current-prefix-arg))
  (let ((remove-msg (and display-msgs
                         (substitute-command-keys
                          "`\\[negative-argument] \\[highlight]' to remove \
all highlighting in region."))))
    (when display-msgs
      (if (fboundp 'display-in-minibuffer)
          (display-in-minibuffer 'new "Highlighting occurrences of `"
                                 (list (if (boundp 'blue-foreground-face)
                                           blue-foreground-face
                                         'highlight)
                                       regexp)
                                 "' after cursor ...")
        (message (concat "Highlighting occurrences of `" regexp
                         "' after cursor ..."))))
    (highlight-regexp-region (point) (point-max) regexp face
                             (and display-msgs 'error-msgs-only)
                             mouse-p nth)
    (when display-msgs
      (if (fboundp 'display-in-minibuffer)
          (display-in-minibuffer 'more-event " done.  " remove-msg)
        (message (concat "Highlighting occurrences of `" regexp " done.  "
                         remove-msg)))))
  (setq highlight-last-regexp regexp))

;;;###autoload
(defun highlight-regexp-region (start end regexp face
                                      &optional display-msgs mouse-p nth)
  "Highlight regular expression REGEXP with FACE in region
from START to END.
Optional 5th arg DISPLAY-MSGS:
  t => Treat as interactive call in deciding to display all messages.
  non-nil & non-t => Display only error and warning messages.
Optional 6th arg MOUSE-P non-nil => `mouse-face' property, not `face'.
  Interactively, MOUSE-P is provided by the prefix arg.
Optional 7th arg NTH determines which regexp subgroup is highlighted.
  If nil or 0, the entire regexp is highlighted.  Otherwise, the NTH
  regexp subgroup (\"\\\\( ... \\\\)\" expression) is highlighted.
  (NTH is not available interactively.)"
  (interactive
   (list (region-beginning) (region-end)
         (read-string "Regexp to highlight in region: " highlight-last-regexp)
         (read-face-name "Use highlighting face: ")
         t current-prefix-arg))         ; interactive-p => Display all msgs.
  (unless (stringp regexp)              ; Else re-search-forward gets an error
    (error "HIGHLIGHT-REGEXP-REGION: REGEXP arg is not a string: `%S'" regexp))
  (let ((reg-size (abs (- end start))))
    (when (and display-msgs
               (> reg-size max-highlight-w-o-warning)
               (not (progn
                      (and (fboundp 'flash-ding) ; In `frame-fns.el'
                           (flash-ding 'no-terminate-macros (selected-frame)))
                      (y-or-n-p (substitute-command-keys
                                 (format "Lots of highlighting slows \
things down.  Do you really want to highlight up to %d chars?  "
                                         reg-size))))))
      (error "OK, highlighting was cancelled.")))
  (when (eq t display-msgs)
    (if (fboundp 'display-in-minibuffer)
        (display-in-minibuffer 'new "Highlighting occurrences of `"
                               (list (if (boundp 'blue-foreground-face)
                                         blue-foreground-face
                                       'highlight)
                                     regexp)
                               "' in region ...")
      (message (concat "Highlighting occurrences of `" regexp
                       "' in region ..."))))
  (save-excursion
    (goto-char start)
    (while (re-search-forward regexp end t)
      (highlight-region (match-beginning (or nth 0))
                        (match-end (or nth 0)) face)))
  (when (eq t display-msgs)
    (if (fboundp 'display-in-minibuffer)
        (display-in-minibuffer 'more-event " done.  " (substitute-command-keys
                                                       "`\\[negative-argument] \
\\[highlight]' to remove all highlighting in region."))
      (message (concat "Highlighting occurrences of `" regexp " done.  "
                       (substitute-command-keys
                        "`\\[negative-argument] \
\\[highlight]' to remove all highlighting in region.")))))
  (setq highlight-last-regexp regexp))

;;;###autoload
(defun mouse-face-following-lines ()
  "Put `mouse-face' on line of cursor and each following line."
  (let ((buffer-read-only nil))
    (save-excursion
      (while (not (eobp))
        (put-text-property (point) (progn (end-of-line) (point))
                           'mouse-face 'highlight)
        (forward-line 1)))))

;;;###autoload
(defun mouse-face-each-line ()
  "Put `mouse-face' on each line of buffer (restriction)."
  (let ((buffer-read-only nil))
    (save-excursion
      (goto-char (point-min))
      (while (not (eobp))
        (put-text-property (point) (progn (end-of-line) (point))
                           'mouse-face 'highlight)
        (forward-line 1)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; `highlight.el' ends here