code/regexp-lock.el

   1 ;; http://lists.gnu.org/archive/html/gnu-emacs-sources/2005-11/msg00004.html
   2
   3 ;; gnu-emacs-sources
   4 ;; regexp-lock.el
   5 ;; From:        martin rudalics
   6 ;; Subject:     regexp-lock.el
   7 ;; Date:        Sun, 06 Nov 2005 18:31:42 +0100
   8
   9 ;;; regexp-lock.el --- minor mode for highlighting Emacs Lisp regexps
  10
  11
  12 ;; Copyright (C) 2005 Martin Rudalics
  13
  14
  15 ;; Author: Martin Rudalics <r u d a l i c s @ g m x . a t>
  16 ;; Keywords: regular expressions
  17 ;; Version: 0.1
  18
  19
  20 ;; regexp-lock.el is free software; you can redistribute it and/or modify
  21 ;; it under the terms of the GNU General Public License as published by
  22 ;; the Free Software Foundation; either version 2, or (at your option)
  23 ;; any later version.
  24
  25
  26 ;; regexp-lock.el is distributed in the hope that it will be useful,
  27 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  28 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  29 ;; GNU General Public License for more details.
  30
  31
  32 ;;; Commentary:
  33
  34
  35 ;; Regexp Lock is a minor mode for highlighting regular expressions in Emacs
  36 ;; Lisp mode.
  37
  38
  39 ;; `regexp-lock-mode' turns on/off Regexp Lock in the current buffer.  For
  40 ;; further information consult the documentation of `regexp-lock-mode'.
  41
  42
  43 ;; To turn on Regexp Lock in any Emacs Lisp file you open, add the lines
  44 ;;   (require 'regexp-lock)
  45 ;;   (add-hook 'emacs-lisp-mode-hook 'turn-on-regexp-lock-mode)
  46 ;; to your .emacs.
  47
  48
  49 ;;; Code:
  50
  51
  52 ;; _____________________________________________________________________________
  53 ;;
  54 ;;;                      Faces and customizable variables
  55 ;; _____________________________________________________________________________
  56 ;;
  57 (defgroup regexp-lock nil
  58   "Highlight regular expressions in Lisp modes."
  59   :version "22.1"
  60   :group 'font-lock)
  61
  62
  63 (defface regexp-lock-regexp
  64   '((((class color)) :background "Grey87")
  65     (t :underline t))
  66   "Face for highlighting regexp at point."
  67   :group 'regexp-lock)
  68
  69
  70 (defface regexp-lock-group
  71   '((((class color)) :bold t :foreground "Black" :background "Orange")
  72     (t :bold t))
  73   "Face for highlighting group numbers in regexp at point."
  74   :group 'regexp-lock)
  75
  76
  77 (defface regexp-lock-match
  78   '((((class color)) :background "Turquoise1")
  79     (t :underline t))
  80   "Face for highlighting match of regexp at point."
  81   :group 'regexp-lock)
  82
  83
  84 (defface regexp-lock-match-group
  85   '((((class color)) :bold t :foreground "Black" :background "Turquoise1")
  86     (t :bold t))
  87   "Face for highlighting group numbers in match of regexp at point."
  88   :group 'regexp-lock)
  89
  90
  91 (defface regexp-lock-match-other
  92   '((((class color)) :background "PaleTurquoise1")
  93     (t :underline t))
  94   "Face for highlighting other matches of regexp at point."
  95   :group 'regexp-lock)
  96
  97
  98 (defcustom regexp-lock-minor-mode-string nil
  99   "*String to display in mode line when Regexp Lock is enabled."
 100   :type '(choice string (const :tag "none" nil))
 101   :group 'regexp-lock)
 102
 103
 104 (defcustom regexp-lock-regexp-string
 105   "\\\\\\\\[](|)>}`'=_sSwWcCbB0-9]\\|\\[\\(?:[ ^:]\\|\\\\[tnf]\\)\\|\\][*+?]"
 106   "*Strings matching this regexp are considered regexp subexpressions.
 107
 108
 109 This regexp is used to discriminate strings representing regular
 110 expressions from \"ordinary\" strings.  The default value has Regexp
 111 Lock search for one of the following:
 112
 113
 114 - two backslashes preceding any of the characters expected in regexp
 115   backslash constructs but \"[\", \"{\" and \"<\" - the latter being
 116   excluded because the corresponding constructs have a special meaning
 117   in `substitute-command-keys'
 118
 119
 120 - a left bracket followed by a space, a caret, a colon, or a backslash
 121   that precedes one of the characters \"t\", \"n\", or \"f\"
 122
 123
 124 - a right bracket followed by one of \"*\", \"+\", or \"?\"
 125
 126
 127 If any of these items is present in a string, that individual string is
 128 considered part of a regular expression.  If, moreover, the string
 129 literally appears within the argument list of a `concat' or `mapconcat',
 130 all components of that list are considered regular expressions too."
 131   :type 'regexp
 132   :group 'regexp-lock)
 133
 134
 135 (defcustom regexp-lock-redo-delay 0.1
 136   "*Time in seconds Regexp Lock waits before refontifying text.
 137
 138
 139 By default, Regexp Lock refontifies text in order to correctly assign
 140 the text properties of all regexps displayed.  When the value of this
 141 variable is nil Regexp Lock never refontifies text.  As a consequence
 142 regexps may appear improperly fontified after a buffer has been altered,
 143 scrolled, or is displayed for the first time."
 144   :type '(choice (const :tag "never" nil) (number :tag "seconds"))
 145   :set (lambda (symbol value)
 146          (set-default symbol value)
 147          (when (boundp 'regexp-lock-redo-timer)
 148            (when regexp-lock-redo-timer
 149              (cancel-timer regexp-lock-redo-timer)
 150              (setq regexp-lock-redo-timer nil))
 151            (when value
 152              (setq regexp-lock-redo-timer
 153                    (run-with-idle-timer value t 'regexp-lock-redo)))))
 154   :group 'regexp-lock)
 155
 156
 157 (defcustom regexp-lock-pause nil
 158   "*Time in seconds Regexp Lock pauses during refontifying and rechecking.
 159
 160
 161 When the value of this variable is nil `regexp-lock-redo' and
 162 `regexp-lock-recheck' never pause."
 163   :type '(choice (const :tag "never" nil) (number :tag "seconds"))
 164   :group 'regexp-lock)
 165
 166
 167 (defcustom regexp-lock-redo-size 500
 168   "*Number of characters Regexp Lock refontifies without pause."
 169   :type 'integer
 170   :group 'regexp-lock)
 171
 172
 173 (defcustom regexp-lock-recheck-delay 1
 174   "*Time in seconds Regexp Lock waits before rechecking.
 175
 176
 177 Rechecking is needed since refontification \(`regexp-lock-redo'\) can
 178 not tell whether a multi-line string that matches - or does not match -
 179 `regexp-lock-regexp-string' did so in earlier fontifications too.  The
 180 function `regexp-lock-recheck' periodically checks strings whether they
 181 \(still\) qualify as regexp subexpressions.  It does so by searching
 182 windows for `regexp-lock-regexp-string' and requesting refontification
 183 whenever the semantics of a string might have changed.  If the value of
 184 regexp-lock-recheck-delay is nil no rechecking is done.
 185
 186
 187 In practice, the semantics of expressions change rarely.  A noticeable
 188 exception occurs when you compose a regexp spanning multiple lines and
 189 the first match for `regexp-lock-regexp-string' does not occur on the
 190 first lines."
 191   :type '(choice (const :tag "never" nil) (number :tag "seconds"))
 192   :set (lambda (symbol value)
 193          (set-default symbol value)
 194          (when (boundp 'regexp-lock-recheck-timer)
 195            (when regexp-lock-recheck-timer
 196              (cancel-timer regexp-lock-recheck-timer)
 197              (setq regexp-lock-recheck-timer nil))
 198            (when value
 199              (setq regexp-lock-recheck-timer
 200                    (run-with-idle-timer value t 'regexp-lock-recheck)))))
 201   :group 'regexp-lock)
 202
 203
 204 (defcustom regexp-lock-show-priority 1000
 205   "*Priority of overlays highlighting the regexp at point.
 206
 207
 208 Regexp Lock uses this priority for overlays highlighting the regexp at
 209 point and group numbers."
 210   :type 'integer
 211   :group 'regexp-lock)
 212
 213
 214 (defcustom regexp-lock-show-delay 0.2
 215   "*Time in seconds to wait before highlighting the regexp at point.
 216
 217
 218 Regexp Lock waits this many seconds before highlighting the regexp at
 219 point and any group numbers.  A value of nil means that no such
 220 highlighting is performed."
 221   :type '(choice (const :tag "never" nil) (number :tag "seconds"))
 222   :set (lambda (symbol value)
 223          (set-default symbol value)
 224          (when (boundp 'regexp-lock-show-timer)
 225            (when regexp-lock-show-timer
 226              (cancel-timer regexp-lock-show-timer))
 227            (setq regexp-lock-show-timer nil)
 228            (when value
 229              (setq regexp-lock-show-timer
 230                    (run-with-idle-timer value t 'regexp-lock-show)))))
 231   :group 'regexp-lock)
 232
 233
 234 (defcustom regexp-lock-match-before-group "{"
 235   "*String displayed before group number of matching expression.
 236
 237
 238 Matching the regexp at point has Regexp Lock display group numbers of
 239 corresponding regexp subexpressions.  These numbers are indicated with
 240 the help of overlays appearing before and after the match.  If two or
 241 more subexpressions match at the same position, you may discriminate
 242 them more easily by displaying this string before any group number."
 243   :type 'string
 244   :group 'regexp-lock)
 245
 246
 247 (defcustom regexp-lock-match-after-group "}"
 248   "*String displayed after group number of matching expression.
 249
 250
 251 Matching the regexp at point has Regexp Lock display group numbers of
 252 corresponding regexp subexpressions.  These numbers are indicated with
 253 the help of overlays appearing before and after the match.  If two or
 254 more subexpressions match at the same position, you may discriminate
 255 them more easily by displaying this string after any group number."
 256   :type 'string
 257   :group 'regexp-lock)
 258
 259
 260 (defcustom regexp-lock-hook nil
 261   "Hook run after Regexp Lock has been turned on or off."
 262   :type 'hook
 263   :group 'regexp-lock)
 264
 265
 266 ;; _____________________________________________________________________________
 267 ;;
 268 ;;;                              Mode definitions
 269 ;; _____________________________________________________________________________
 270 ;;
 271 (define-minor-mode regexp-lock-mode
 272   "Toggle Regexp Lock.
 273
 274
 275 Regexp Lock is a minor mode for highlighting regular expressions in
 276 Emacs Lisp mode.  When activated, it has font-lock modify syntactic
 277 properties and appearance of regexp constituents as follows:
 278
 279
 280 - Ordinary brackets, parentheses, and semicolons are assigned the
 281   `symbol' syntax-table property.  As a consequence, `forward-sexp' and
 282   `backward-sexp' within strings will skip parenthesized groups and
 283   alternatives in a more intuitive way.  `blink-matching-open' and
 284   `show-paren-mode' will not falsely indicate mismatching parens.
 285
 286
 287 - Brackets delimiting character alternatives are highlighted with
 288   `font-lock-regexp-grouping-construct' face.  Special parentheses and
 289   brackets that don't match are signaled with `font-lock-warning-face'.
 290
 291
 292 - Highlight the regular expression at point with `regexp-lock-regexp'
 293   face.  Also overlay the backslashes used to escape subgroup delimiting
 294   parens with the associated group number.  Group numbers are displayed
 295   with `regexp-lock-group' face.  These overlays are installed whenever
 296   `point' is immediately before or after a string or subgroup delimiter
 297   of the regexp at point.
 298
 299
 300 The commands \\[regexp-lock-match-next] and \\[regexp-lock-match-prev]
 301 can be used to highlight the next respectively previous expression
 302 matching the regexp at point in another window.  These commands use
 303 `eval' to evaluate the regexp at point.  For the current match they
 304 highlight:
 305
 306
 307 - The entire match `(match-string 0)' with `regexp-lock-match' face.
 308
 309
 310 - Group numbers corresponding to subgroup matches are highlighted with
 311   `regexp-lock-match-group' face.  In addition, the strings specified by
 312   `regexp-lock-match-before-group' and `regexp-lock-match-after-group'
 313   are used to separate group numbers.
 314
 315
 316 Matches before and after the current match are highlighted with
 317 `regexp-lock-match-other' face.  If necessary, Regexp Lock splits the
 318 selected window in order to display matches.  Initially, matches are
 319 shown for the buffer containing the regexp at point.  Matches for any
 320 other buffer can be shown by switching to that buffer in the window
 321 displaying matches.
 322
 323
 324 Finally, Regexp Lock provides a function `regexp-lock-increment' which
 325 permits to in-/decrement arguments of `match-beginning' or `match-end'
 326 within the region.
 327
 328
 329
 330 Caveats:
 331
 332
 333 - Regexp Lock uses a number of heuristics to detect regexps.  Hence you
 334   will occasionally see ordinary strings highlighted as regexps as well
 335   as regexps highlighted as ordinary strings.  In some cases customizing
 336   the variable `regexp-lock-regexp-string' might help.
 337
 338
 339 - Regexp Lock analyzes regular expressions literally.  Hence if you
 340   write something like
 341
 342
 343   \(defvar foo \"\\\\(\") \(defvar bar (concat foo \"bar\\\\)\"))
 344
 345
 346   Regexp Lock is not able to indicate group numbers correctly and will
 347   additionally issue two warnings.
 348
 349
 350 - Regexp Lock expects that a regexp produced by `regexp-opt' is
 351   contained in a grouping construct iff the second argument of
 352   regexp-opt is present and does not equal one of the character
 353   sequences `nil' or `()'.
 354
 355
 356 - Regexp Lock does not recognize expressions constructed by `rx' or
 357   `sregex'.
 358
 359
 360 - Regexp Lock consumes processor resources.  On battery-powered systems
 361   you should turn it off whenever you don't need it."
 362   :lighter regexp-lock-minor-mode-string
 363   :group 'regexp-lock
 364   :keymap '(("\C-c(" . regexp-lock-match-next)
 365             ("\C-c)" . regexp-lock-match-prev)
 366             ("\C-c#" . regexp-lock-increment))
 367   (if regexp-lock-mode
 368       (regexp-lock-activate)
 369     (regexp-lock-deactivate))
 370   (run-hooks 'regexp-lock-hook))
 371
 372
 373 (defun turn-on-regexp-lock-mode ()
 374   "Unequivocally turn on `regexp-lock-mode'."
 375   (interactive)
 376   (regexp-lock-mode 1))
 377
 378
 379 ;; _____________________________________________________________________________
 380 ;;
 381 ;;;                          Local definitions
 382 ;; _____________________________________________________________________________
 383 ;;
 384 (defvar regexp-lock-redo t
 385   "When non-nil refontify this buffer.")
 386
 387
 388 (defvar regexp-lock-redo-timer nil
 389   "Idle timer for `regexp-lock-redo'.")
 390
 391
 392 (defvar regexp-lock-recheck t
 393   "When non-nil recheck this buffer.")
 394
 395
 396 (defvar regexp-lock-recheck-timer nil
 397   "Idle timer for `regexp-lock-recheck'.")
 398
 399
 400 (defvar regexp-lock-overlays nil
 401   "Overlays used by `regexp-lock-show'.")
 402
 403
 404 (defvar regexp-lock-show-timer nil
 405   "Idle timer for `regexp-lock-show'.")
 406
 407
 408 (defvar regexp-lock-match-regexp nil
 409   "`regexp-lock-match' searches for this regexp.")
 410
 411
 412 (defvar regexp-lock-match-window nil
 413   "`regexp-lock-match' display matches in this window.")
 414
 415
 416 (defvar regexp-lock-match-buffer nil
 417   "`regexp-lock-match-window' displays this buffer.")
 418
 419
 420 (defvar regexp-lock-match-overlays nil
 421   "Overlays that highlight matches in `regexp-lock-match-window'.")
 422
 423
 424 (defvar regexp-lock-match-from (make-marker)
 425   "Marker for match begin in `regexp-lock-match-buffer'.")
 426
 427
 428 (defvar regexp-lock-match-to (make-marker)
 429   "Marker for match end in `regexp-lock-match-buffer'.")
 430
 431
 432 (eval-when-compile
 433   (defmacro save-regexp-lock (&rest body)
 434     "Eval BODY with match-data, excursion, restrictions saved, buffer widened."
 435     `(save-match-data
 436        (save-excursion
 437          (save-restriction
 438            (widen)
 439            (progn ,@body)))))
 440   (put 'save-regexp-lock 'lisp-indent-function 0)
 441   (def-edebug-spec save-regexp-lock let)
 442   (defmacro with-regexp-lock (&rest body)
 443     "Eval BODY, preserving current buffer's modified and undo states."
 444     (let ((modified (make-symbol "modified")))
 445       `(let ((,modified (buffer-modified-p))
 446              (buffer-undo-list t)
 447              (inhibit-read-only t)
 448              (inhibit-point-motion-hooks t)
 449              (inhibit-modification-hooks t)
 450              deactivate-mark
 451              buffer-file-name
 452              buffer-file-truename)
 453          (unwind-protect
 454              (progn ,@body)
 455            (unless ,modified
 456              (restore-buffer-modified-p nil))))))
 457   (put 'with-regexp-lock 'lisp-indent-function 0)
 458   (def-edebug-spec with-regexp-lock let))
 459
 460
 461 (defsubst regexp-lock-string-face-p (face)
 462   "Return t when character at `point' has `font-lock-string-face' face
 463 property."
 464   (or (and (listp face)
 465            (memq 'font-lock-string-face face))
 466       (eq face 'font-lock-string-face)))
 467
 468
 469 (defsubst regexp-lock-syntactic-face-p (face)
 470   "Return t when face property at `point' indicates syntactic context.
 471
 472
 473 More precisely, return t when character at point has one of
 474 `font-lock-string-face', `font-lock-comment-face', or
 475 `font-lock-doc-face' face property."
 476   (or (and (listp face)
 477            (or (memq 'font-lock-string-face face)
 478                (memq 'font-lock-comment-face face)
 479                (memq 'font-lock-doc-face face)))
 480       (memq face '(font-lock-string-face
 481                    font-lock-comment-face
 482                    font-lock-doc-face))))
 483
 484
 485 ;; the following function is commented out in font-lock.el
 486 (defun remove-text-property (start end property &optional object)
 487  "Remove a property from text from START to END.
 488 Argument PROPERTY is the property to remove.
 489 Optional argument OBJECT is the string or buffer containing the text.
 490 Return t if the property was actually removed, nil otherwise."
 491  (remove-text-properties start end (list property) object))
 492
 493
 494 ;; the following function is commented out in font-lock.el
 495 (defun remove-single-text-property (start end prop value &optional object)
 496  "Remove a specific property value from text from START to END.
 497 Arguments PROP and VALUE specify the property and value to remove.  The
 498 resulting property values are not equal to VALUE nor lists containing VALUE.
 499 Optional argument OBJECT is the string or buffer containing the text."
 500  (let ((start (text-property-not-all start end prop nil object)) next prev)
 501    (while start
 502      (setq next (next-single-property-change start prop object end)
 503             prev (get-text-property start prop object))
 504      (cond ((and (symbolp prev) (eq value prev))
 505              (remove-text-property start next prop object))
 506             ((and (listp prev) (memq value prev))
 507              (let ((new (delq value prev)))
 508                (cond ((null new)
 509                       (remove-text-property start next prop object))
 510                      ((= (length new) 1)
 511                       (put-text-property start next prop (car new) object))
 512                      (t
 513                       (put-text-property start next prop new object))))))
 514      (setq start (text-property-not-all next end prop nil object)))))
 515
 516
 517 ;; _____________________________________________________________________________
 518 ;;
 519 ;;;                        Activate / Deactivate
 520 ;; _____________________________________________________________________________
 521 ;;
 522 (defun regexp-lock-activate ()
 523   "Activate Regexp Lock in current buffer."
 524   (if (not (memq major-mode
 525                  '(emacs-lisp-mode lisp-mode lisp-interaction-mode reb-mode)))
 526       (error "Regexp Lock can be used in Lisp modes only")
 527     ;; turn on font-lock if necessary and integrate ourselves
 528     (unless font-lock-mode (font-lock-mode 1))
 529     (set (make-local-variable 'font-lock-extra-managed-props)
 530          (append font-lock-extra-managed-props
 531                  (list 'syntax-table 'regexp-lock)))
 532     (font-lock-add-keywords nil '(regexp-lock-fontify . nil) t)
 533     (font-lock-unfontify-buffer)
 534     (save-restriction
 535       (widen)
 536       (with-regexp-lock
 537         (remove-text-properties (point-min) (point-max) '(fontified t))))
 538     ;; syntax properties
 539     (set (make-local-variable 'parse-sexp-lookup-properties) t)
 540     ;; hooks
 541     (add-hook 'after-change-functions 'regexp-lock-after-change nil t)
 542     (add-hook 'window-scroll-functions 'regexp-lock-window-redo t t)
 543     (add-hook 'window-size-change-functions 'regexp-lock-frame-redo)
 544     (add-hook 'change-major-mode-hook 'regexp-lock-deactivate nil t)
 545     ;; redo-timer
 546     (when regexp-lock-redo-timer
 547       (cancel-timer regexp-lock-redo-timer)
 548       (setq regexp-lock-redo-timer nil))
 549     (when regexp-lock-redo-delay
 550       (setq regexp-lock-redo-timer
 551             (run-with-idle-timer regexp-lock-redo-delay t 'regexp-lock-redo)))
 552     (set (make-local-variable 'regexp-lock-redo) nil)
 553     ;; recheck-timer
 554     (when regexp-lock-recheck-timer
 555       (cancel-timer regexp-lock-recheck-timer)
 556       (setq regexp-lock-recheck-timer nil))
 557     (when regexp-lock-recheck-delay
 558       (setq regexp-lock-recheck-timer
 559             (run-with-idle-timer
 560              regexp-lock-recheck-delay t 'regexp-lock-recheck)))
 561     (set (make-local-variable 'regexp-lock-recheck) nil)
 562     ;; show-timer
 563     (when regexp-lock-show-timer
 564       (cancel-timer regexp-lock-show-timer)
 565       (setq regexp-lock-show-timer nil))
 566     (when regexp-lock-show-delay
 567       (setq regexp-lock-show-timer
 568             (run-with-idle-timer regexp-lock-show-delay t 'regexp-lock-show)))))
 569
 570
 571 (defun regexp-lock-deactivate ()
 572   "Deactivate Regexp Lock in current buffer."
 573   ;; syntax properties
 574   (setq parse-sexp-lookup-properties nil)
 575   ;; local hooks
 576   (remove-hook 'after-change-functions 'regexp-lock-after-change)
 577   (remove-hook 'window-scroll-functions 'regexp-lock-window-redo)
 578   (remove-hook 'change-major-mode-hook 'regexp-lock-deactivate)
 579   (remove-hook 'pre-command-hook 'regexp-lock-match-pre-command)
 580   ;; redo
 581   (with-regexp-lock
 582     (remove-text-properties (point-min) (point-max) '(regexp-lock-redo nil)))
 583   ;; font lock
 584   (font-lock-unfontify-buffer)
 585   (setq font-lock-extra-managed-props
 586         (delq 'syntax-table
 587               (delq 'regexp-lock
 588                     font-lock-extra-managed-props)))
 589   (font-lock-remove-keywords nil '(regexp-lock-fontify . nil))
 590   (save-restriction
 591     (widen)
 592     (with-regexp-lock
 593       (remove-text-properties (point-min) (point-max) '(fontified t))))
 594   (unless (catch 'found
 595             (dolist (buffer (buffer-list))
 596               (when (with-current-buffer buffer regexp-lock-mode)
 597                 (throw 'found t))))
 598     ;; markers
 599     (set-marker regexp-lock-match-from nil)
 600     (set-marker regexp-lock-match-to nil)
 601     ;; global hook
 602     (remove-hook 'window-size-change-functions 'regexp-lock-frame-redo)
 603     ;; redo-timer
 604     (when regexp-lock-redo-timer
 605       (cancel-timer regexp-lock-redo-timer)
 606       (setq regexp-lock-redo-timer nil))
 607     ;; recheck-timer
 608     (when regexp-lock-recheck-timer
 609       (cancel-timer regexp-lock-recheck-timer)
 610       (setq regexp-lock-recheck-timer nil))
 611     ;; show-timer
 612     (when regexp-lock-show-timer
 613       (cancel-timer regexp-lock-show-timer)
 614       (setq regexp-lock-show-timer nil))))
 615
 616
 617 ;; _____________________________________________________________________________
 618 ;;
 619 ;;;                           Text Properties
 620 ;; _____________________________________________________________________________
 621 ;;
 622 (defun regexp-lock-after-change (start end old-len)
 623   "Mark text after buffer change to trigger `regexp-lock-redo'."
 624   (when regexp-lock-mode
 625     (with-regexp-lock
 626       (save-excursion
 627         (goto-char start)
 628         (if (save-match-data
 629               (save-excursion
 630                 (beginning-of-line)
 631                 (re-search-forward
 632                  regexp-lock-regexp-string (max end (line-end-position)) t)))
 633             (put-text-property
 634              (line-beginning-position) (min (max end (1+ start)) (point-max))
 635              'regexp-lock-redo 2)
 636           (put-text-property
 637            (line-beginning-position) (min (max end (1+ start)) (point-max))
 638            'regexp-lock-redo t))
 639         (setq regexp-lock-redo t)))))
 640
 641
 642 (defun regexp-lock-window-redo (window start)
 643   "Mark text after window scroll to trigger `regexp-lock-redo'."
 644   (with-current-buffer (window-buffer window)
 645     (when regexp-lock-mode
 646       (setq regexp-lock-redo t))))
 647
 648
 649 (defun regexp-lock-frame-redo (frame)
 650   "Mark text after window size change to trigger `regexp-lock-redo'."
 651   ;; Use frame-first-window since selected-window may be on a different frame.
 652   (with-selected-window (frame-first-window frame)
 653     (dolist (window (window-list frame 'nominibuf))
 654       (with-current-buffer (window-buffer window)
 655         (when regexp-lock-mode
 656           (setq regexp-lock-redo t))))))
 657
 658
 659 (defun regexp-lock-redo ()
 660   "Refontify with Regexp Lock.
 661
 662
 663 Currently this operates on all windows of the selected frame."
 664   (catch 'input
 665     (let ((current-buffer (current-buffer))
 666           (current-point (point))
 667           (current-point-min (point-min))
 668           (current-point-max (point-max)))
 669       (dolist (window (window-list nil 'nominibuf))
 670         (with-current-buffer (window-buffer window)
 671           (when (and regexp-lock-mode regexp-lock-redo font-lock-mode)
 672             (let ((window-start (window-start window))
 673                   (window-end (window-end window))
 674                   (parse-sexp-ignore-comments t))
 675               (save-regexp-lock
 676                (let* ((bod (save-excursion
 677                              ;; bod is the last beginning-of-defun
 678                              ;; preceding start of window or point-min
 679                              (goto-char window-start)
 680                              (or (condition-case nil
 681                                      (progn
 682                                        (beginning-of-defun)
 683                                        (line-beginning-position))
 684                                    (error (point-min)))
 685                                  (point-min))))
 686                       (eod (save-excursion
 687                              ;; eod is the first end-of-defun following
 688                              ;; end of window or point-max
 689                              (goto-char window-end)
 690                              (or (condition-case nil
 691                                      (progn
 692                                        (beginning-of-defun -1)
 693                                        (max window-end
 694                                             (line-beginning-position)))
 695                                    (error (point-max)))
 696                                  (point-max))))
 697                       ;; from is the first redo position between bod
 698                       ;; and eod
 699                       (from (min (or (text-property-any
 700                                       bod eod 'regexp-lock-redo t)
 701                                      eod)
 702                                  (or (text-property-any
 703                                       bod eod 'fontified nil)
 704                                      eod)))
 705                       to)
 706                  (when (and from (< from eod))
 707                    (save-excursion
 708                      (goto-char from)
 709                      (setq from (line-beginning-position)))
 710                    ;; adjust from
 711                    (when (or (< from bod)
 712                              (and (> from bod)
 713                                   (not (get-text-property
 714                                         (1- from) 'fontified))))
 715                      ;; refontify from bod
 716                      (setq from bod))
 717                    ;; initialize to
 718                    (when (or (< from window-end)
 719                              (not (equal (get-text-property
 720                                           (1- from) 'regexp-lock)
 721                                          (get-text-property
 722                                           from 'regexp-lock))))
 723                      (setq to (min (save-excursion
 724                                      (goto-char
 725                                       (+ from regexp-lock-redo-size))
 726                                      (line-beginning-position 2))
 727                                    eod))
 728                      ;; fontify
 729                      (while (and (< from to)
 730                                  (or (not regexp-lock-pause)
 731                                      (save-excursion
 732                                        (with-current-buffer current-buffer
 733                                          (save-restriction
 734                                            (goto-char current-point)
 735                                            (narrow-to-region
 736                                             current-point-min
 737                                             current-point-max)
 738                                            (sit-for regexp-lock-pause))))
 739                                      (throw 'input t)))
 740                        (with-regexp-lock
 741                          ;; record the following two properties _now_
 742                          ;; since font-lock may fontify past to
 743                          (let ((fontified-at-to
 744                                 (get-text-property to 'fontified))
 745                                (lock-at-to
 746                                 (get-text-property to 'regexp-lock)))
 747                            (put-text-property from to 'fontified t)
 748                            (if jit-lock-mode
 749                                ;; as jit-lock-fontify-now
 750                                (condition-case err
 751                                    (run-hook-with-args
 752                                     'jit-lock-functions from to)
 753                                  (quit (put-text-property
 754                                         from to 'fontified nil)
 755                                        (funcall
 756                                         'signal (car err) (cdr err))))
 757                              ;; plain font-lock-fontify-region
 758                              (font-lock-fontify-region from to))
 759                            (remove-text-properties
 760                             from to '(regexp-lock-redo nil))
 761                            (setq from to)
 762                            (when (and (< to eod)
 763                                       (or (not fontified-at-to)
 764                                           (not (equal (get-text-property
 765                                                        (1- to) 'regexp-lock)
 766                                                       lock-at-to))))
 767                              (put-text-property
 768                               to (min (1+ to) (point-max))
 769                               'regexp-lock-redo t)
 770                              (setq to (min (save-excursion
 771                                              (goto-char
 772                                               (+ to regexp-lock-redo-size))
 773                                              (line-beginning-position 2))
 774                                            eod))))))))))
 775               ;; keep the following always _within_ the outermost
 776               ;; let to avoid that other idle timers get confused
 777               (timer-activate-when-idle regexp-lock-show-timer t)
 778               (setq regexp-lock-redo nil)
 779               (setq regexp-lock-recheck t))))
 780         (or (not regexp-lock-pause)
 781             (sit-for regexp-lock-pause)
 782             (throw 'input t))))))
 783
 784
 785 (defsubst regexp-lock-set-redo (from to)
 786   "Set `regexp-lock-redo' from `regexp-lock-recheck'.
 787
 788
 789 This sets the `regexp-lock-redo' text-property at FROM as well as the
 790 buffer-local value of `regexp-lock-redo' to t.  Values are set if a
 791 match for `regexp-lock-regexp-string' is found before TO and the
 792 `regexp-lock' text-property at FROM is not set or no match before TO
 793 exists and the `regexp-lock' text-property is set."
 794   (if (re-search-forward regexp-lock-regexp-string to 'to)
 795       ;; match for regexp-lock-regexp-string
 796       (unless (get-text-property from 'regexp-lock)
 797         ;; regexp-lock not set, redo
 798         (with-regexp-lock
 799           (put-text-property from (1+ from) 'regexp-lock-redo t))
 800         (setq regexp-lock-redo t))
 801     ;; no match for regexp-lock-regexp-string
 802     (when (get-text-property from 'regexp-lock)
 803       ;; regexp-lock set, redo
 804       (with-regexp-lock
 805         (put-text-property from (1+ from) 'regexp-lock-redo t))
 806       (setq regexp-lock-redo t))))
 807
 808
 809 (defun regexp-lock-recheck ()
 810   "Recheck windows with Regexp Lock.
 811
 812
 813 Currently this operates on all windows of the selected frame."
 814   (catch 'input
 815     (let ((current-buffer (current-buffer))
 816           (current-point (point))
 817           (current-point-min (point-min))
 818           (current-point-max (point-max)))
 819       (dolist (window (window-list nil 'nominibuf))
 820         (with-current-buffer (window-buffer window)
 821           (when (and regexp-lock-mode regexp-lock-recheck font-lock-mode)
 822             (let ((window-start (window-start window))
 823                   (window-end (window-end window))
 824                   (parse-sexp-ignore-comments t))
 825               (save-regexp-lock
 826                (let* ((from (save-excursion
 827                               ;; from is the last beginning-of-defun
 828                               ;; preceding start of window or point-min
 829                               (goto-char window-start)
 830                               (or (condition-case nil
 831                                       (progn
 832                                         (beginning-of-defun)
 833                                         (line-beginning-position))
 834                                     (error (point-min)))
 835                                   (point-min))))
 836                       to face)
 837                  ;; check iff from has been already fontified
 838                  (when (get-text-property from 'fontified)
 839                    (goto-char from)
 840                    (while (re-search-forward "\\(\"\\)\
 841 \\|(\\(\\(?:map\\)?concat\\)\\>\
 842 \\|(\\(re-search-\\(?:for\\|back\\)ward\\|looking-\\(?:at\\|back\\)\\|string-match\\|replace-regexp-in-string\
 843 \\|message\\|error\\|skip-\\(?:syntax\\|chars\\)-\\(?:for\\|back\\)ward\\|search-\\(?:for\\|back\\)ward\\)\\>"
 844                                              window-end 'window-end)
 845                      (setq face (get-text-property
 846                                  (or (match-end 1) (match-beginning 0))
 847                                  'face))
 848                      (cond
 849                       ((match-beginning 1)
 850                        ;; double-quote
 851                        (cond
 852                         ((and (regexp-lock-string-face-p face)
 853                               (save-excursion
 854                                 (condition-case nil
 855                                     (progn
 856                                       (setq from (match-beginning 1))
 857                                       (goto-char from)
 858                                       (forward-sexp)
 859                                       (setq to (point)))
 860                                   (error nil))))
 861                          (regexp-lock-set-redo from to)
 862                          (goto-char (min to window-end)))
 863                         ((and (or (and (listp face)
 864                                        (memq 'font-lock-doc-face face))
 865                                   (eq 'font-lock-doc-face face))
 866                               (save-excursion
 867                                 (condition-case nil
 868                                     (progn
 869                                       (goto-char (match-beginning 1))
 870                                       (forward-sexp)
 871                                       (setq to (point)))
 872                                   (error nil))))
 873                          ;; doc-string, skip
 874                          (goto-char (min to window-end)))))
 875                       ((match-beginning 2)
 876                        ;; concat, mapconcat
 877                        (when (and (not (regexp-lock-syntactic-face-p face))
 878                                   (save-excursion
 879                                     (condition-case nil
 880                                         (progn
 881                                           (setq from (match-beginning 0))
 882                                           (goto-char from)
 883                                           (forward-sexp)
 884                                           (setq to (point)))
 885                                       (error nil)))
 886                                   (goto-char from))
 887                          (regexp-lock-set-redo from to)
 888                          (goto-char (min to window-end))))
 889                       ((match-beginning 3)
 890                        ;; re-search- / looking- / string-match /
 891                        ;; replace-regexp-in-string /
 892                        ;; message / error / search- / skip-syntax- /
 893                        ;; skip-chars-, skip
 894                        (if (and (not (regexp-lock-syntactic-face-p face))
 895                                 (save-excursion
 896                                   (condition-case nil
 897                                       (progn
 898                                         (goto-char (match-beginning 0))
 899                                         (forward-sexp)
 900                                         (setq to (point)))
 901                                     (error nil))))
 902                            (goto-char (min to window-end))
 903                          (goto-char (min (point) window-end)))))))
 904                  (setq regexp-lock-recheck nil)
 905                  (when regexp-lock-redo
 906                    ;; activate regexp-lock-redo-timer
 907                    (timer-activate-when-idle
 908                     regexp-lock-redo-timer t)))))))))
 909     (or (not regexp-lock-pause)
 910         (sit-for regexp-lock-pause)
 911         (throw 'input t))))
 912
 913
 914 (defun regexp-lock-fontify (bound)
 915   "Fontify region from `point' to BOUND."
 916   (let ((lock (unless (= (point) (point-min))
 917                 (get-text-property (1- (point)) 'regexp-lock)))
 918         ;; `lock' - the `regexp-lock' text property - is interpreted as:
 919         ;; nil - no regexp around point (nil is not stored as text property)
 920         ;; 0 - the following sexp is a regexp
 921         ;; 1 - within a regexp-string that is not argument of a `concat'
 922         ;; >= 2 - within a `concat' that has at least one regexp argument
 923         ;; within a character alternative values are negative
 924         (from (point))
 925         (parse-sexp-ignore-comments t)
 926         to face)
 927     (while (< (point) bound)
 928       (catch 'lock
 929         (if lock
 930             (while (re-search-forward
 931
 932 "\\(^\\s(\\)\\|\\(\"\\)\\|\\(?:\\\\\\\\\\)\\(?:\\(?:\\\\\\\\\\)\\|\\([()]\\)\\|\\(|\\)\\|\\(\\[\\)\\|\\(\\]\\)\\)\
 933 \\|\\(\\\\[][()]\\)\\|\\(\\[:[a-zA-Z]+:\\]\\)\\|\\(\\[\\)\\|\\(\\]\\)\\|\\(;\\)\\|\\((\\)\\|\\()\\)\\|`\\(\\sw\\sw+\\)'"
 934  bound 'bound)
 935               (setq face (get-text-property (1- (point)) 'face))
 936               (cond
 937                ((match-beginning 1)
 938                 ;; paren in column zero, throw
 939                 (put-text-property from (match-beginning 1) 'regexp-lock lock)
 940                 (setq lock nil)
 941                 (throw 'lock nil))
 942                ((match-beginning 2)
 943                 ;; double-quote, ignore for lock not in {-1,0,1}
 944                 (cond
 945                  ((zerop lock)
 946                   ;; start new regexp-string
 947                   (put-text-property from (match-beginning 2) 'regexp-lock 0)
 948                   (setq from (match-beginning 2))
 949                   (goto-char (1+ from))
 950                   (setq lock 1))
 951                  ((and (or (= lock 1) (= lock -1))
 952                        ;; the following skips adjacent double-quotes as in
 953                        ;; "string1""string2" which should not do much harm
 954                        (regexp-lock-string-face-p face)
 955                        (or (= (point) bound) ; fails with escaped `"' at eob
 956                            (not (regexp-lock-string-face-p
 957                                  (get-text-property (point) 'face)))))
 958                   ;; terminate current regexp-string
 959                   (put-text-property from (point) 'regexp-lock lock)
 960                   (when (= lock -1)
 961                     ;; unclosed character alternative, warn
 962                     (put-text-property
 963                      (1- (point)) (point) 'face 'font-lock-warning-face))
 964                   (setq lock nil)
 965                   (throw 'lock nil))))
 966                ((and (match-beginning 12)
 967                      (not (regexp-lock-syntactic-face-p face)))
 968                 ;; non-syntactic left paren, expects lock not in {-1,1}
 969                 (put-text-property from (match-beginning 12) 'regexp-lock lock)
 970                 (setq from (match-beginning 12))
 971                 (cond
 972                  ((>= lock 2) (setq lock (1+ lock)))
 973                  ((<= lock -2) (setq lock (1- lock)))
 974                  ((zerop lock) (setq lock 2))
 975                  (t (setq lock nil)     ; looses
 976                     (throw 'lock nil))))
 977                ((and (match-beginning 13)
 978                      (not (regexp-lock-syntactic-face-p face)))
 979                 ;; non-syntactic right paren, expects lock not in {-1,1}
 980                 (put-text-property from (match-end 13) 'regexp-lock lock)
 981                 (setq from (match-end 13))
 982                 (cond
 983                  ((> lock 2) (setq lock (1- lock)))
 984                  ((< lock -2) (setq lock (1+ lock)))
 985                  (t (when (= lock -2)
 986                       ;; unclosed character alternative, warn
 987                       (put-text-property
 988                        (1- (point)) (point) 'face 'font-lock-warning-face))
 989                     (setq lock nil)     ; end of sexp or looser
 990                     (throw 'lock nil))))
 991                ((regexp-lock-string-face-p face)
 992                 ;; matches below are valid within strings only
 993                 (cond
 994                  ((match-beginning 3)   ; \\( or \\)
 995                   (when (< lock 0)
 996                     ;; within character alternative, set symbol syntax
 997                     (put-text-property (1- (point)) (point) 'syntax-table '(3))
 998                     ;; remove faces that are silly here
 999                     (remove-single-text-property
1000                      (match-beginning 0) (1- (match-end 0))
1001                      'face 'font-lock-regexp-backslash)
1002                     (remove-single-text-property
1003                      (1- (match-end 0)) (match-end 0)
1004                      'face 'font-lock-regexp-grouping-construct)))
1005                  ((match-beginning 4)   ; \\|
1006                   (when (< lock 0)
1007                     ;; within character alternative remove regexp-lock faces
1008                     (remove-single-text-property
1009                      (match-beginning 0) (1- (match-end 0))
1010                      'face 'font-lock-regexp-backslash)
1011                     (remove-single-text-property
1012                      (1- (match-end 0)) (match-end 0)
1013                      'face 'font-lock-regexp-grouping-construct)))
1014                  ((match-beginning 5)   ; \\[
1015                   (let ((face (get-text-property (point) 'face)))
1016                     (when (and (listp face)
1017                                (memq 'font-lock-constant-face face))
1018                       ;; remove font-lock-constant-face
1019                       (remove-single-text-property
1020                        (point) (next-single-property-change
1021                                 (point) 'face nil (line-end-position))
1022                        'face 'font-lock-constant-face)))
1023                   (if (< lock 0)
1024                       ;; within character alternative, reread bracket
1025                       (goto-char (1- (point)))
1026                     ;; not within character alternative, set symbol syntax
1027                     (put-text-property
1028                      (1- (point)) (point) 'syntax-table '(3))))
1029                  ((match-beginning 6)   ; \\]
1030                   (if (< lock 0)
1031                       ;; within character alternative, reread bracket
1032                       (goto-char (1- (point)))
1033                     ;; not within character alternative, set symbol syntax
1034                     (put-text-property
1035                      (1- (point)) (point) 'syntax-table '(3))))
1036                  ((match-beginning 7)   ; escaped parenthesis or bracket
1037                   ;; set symbol syntax for backslash and reread paren
1038                   (put-text-property
1039                    (match-beginning 0) (1+ (match-beginning 0))
1040                    'syntax-table '(3))
1041                   (goto-char (1+ (match-beginning 0))))
1042                  ((match-beginning 8))
1043                  ;; POSIX character class, skip
1044                  ((match-beginning 9)   ; [
1045                   (let ((face (get-text-property (point) 'face)))
1046                     (when (and (listp face)
1047                                (memq 'font-lock-constant-face face))
1048                       ;; remove font-lock-constant-face
1049                       (remove-single-text-property
1050                        (point) (next-single-property-change
1051                                 (point) 'face nil (line-end-position))
1052                        'face 'font-lock-constant-face)))
1053                   (if (< lock 0)
1054                       ;; within character alternative, set symbol syntax
1055                       (put-text-property
1056                        (1- (point)) (point) 'syntax-table '(3))
1057                     ;; start new character alternative
1058                     (put-text-property from (1- (point)) 'regexp-lock lock)
1059                     (setq from (1- (point)))
1060                     (setq lock (- lock))
1061                     (font-lock-prepend-text-property
1062                      (match-beginning 9) (match-end 9)
1063                      'face 'font-lock-regexp-grouping-construct)
1064                     (when (looking-at "\\(?:\\\\?\\^\\)?\\\\?\\(\\]\\)")
1065                       ;; non-special right bracket, set symbol syntax
1066                       (put-text-property
1067                        (match-beginning 1) (match-end 1) 'syntax-table '(3))
1068                       (goto-char (match-end 1)))))
1069                  ((match-beginning 10)  ; ]
1070                   (if (> lock 0)
1071                       ;; not within character alternative, warn
1072                       (font-lock-prepend-text-property
1073                        (match-beginning 10) (match-end 10)
1074                        'face 'font-lock-warning-face)
1075                     ;; terminate alternative
1076                     (font-lock-prepend-text-property
1077                      (match-beginning 10) (match-end 10)
1078                      'face 'font-lock-regexp-grouping-construct)
1079                     (put-text-property from (point) 'regexp-lock lock)
1080                     (setq from (point))
1081                     (setq lock (- lock))))
1082                  ((or (match-beginning 11)
1083                       (match-beginning 12)
1084                       (match-beginning 13)) ; (;), set symbol syntax
1085                   (put-text-property (1- (point)) (point) 'syntax-table '(3)))
1086                  ((match-beginning 14)  ; `..', remove constant face property
1087                   (remove-single-text-property
1088                    (match-beginning 0) (match-end 0)
1089                    'face 'font-lock-constant-face))))))
1090           ;; no lock
1091           (while (re-search-forward "\\(\"\\)\
1092 \\|(\\(re-search-\\(?:for\\|back\\)ward\\|looking-\\(?:at\\|back\\)\\|string-match\\|replace-regexp-in-string\\)\\>\
1093 \\|(\\(\\(?:map\\)?concat\\)\\>\
1094 \\|(\\(message\\|error\\|skip-\\(?:syntax\\|chars\\)-\\(?:for\\|back\\)ward\\|search-\\(?:for\\|back\\)ward\\)\\>"
1095                                     bound 'bound)
1096             (setq face (get-text-property
1097                         (or (match-end 1) (match-beginning 0)) 'face))
1098             (cond
1099              ((match-beginning 1)
1100               ;; double-quote, search for `regexp-lock-regexp-string'
1101               (cond
1102                ((and (regexp-lock-string-face-p face)
1103                      (save-excursion
1104                        (condition-case nil
1105                            (progn
1106                              (setq from (match-beginning 1))
1107                              (goto-char from)
1108                              (forward-sexp)
1109                              (setq to (point)))
1110                          (error nil))))
1111                 (if (re-search-forward regexp-lock-regexp-string to t)
1112                     ;; plain string matching `regexp-lock-regexp-string'
1113                     (progn
1114                       (setq lock 1)
1115                       (goto-char (1+ from))
1116                       (throw 'lock nil))
1117                   ;; plain string that does not match, skip
1118                   (goto-char (min to bound))))
1119                ((and (or (and (listp face) (memq 'font-lock-doc-face face))
1120                          (eq 'font-lock-doc-face face))
1121                      (save-excursion
1122                        (condition-case nil
1123                            (progn
1124                              (goto-char (match-beginning 1))
1125                              (forward-sexp)
1126                              (setq to (point)))
1127                          (error nil))))
1128                 ;; doc-string, skip
1129                 (goto-char (min to bound)))))
1130              ((match-beginning 2)
1131               ;; re-search- / looking- / string-match / replace-regexp-in-string
1132               (unless (regexp-lock-syntactic-face-p face)
1133                 (setq from (match-end 2))
1134                 (setq lock 0)
1135                 (throw 'lock nil)))
1136              ((match-beginning 3)
1137               ;; concat / mapconcat, search arguments for
1138               ;; `regexp-lock-regexp-string'
1139               (if (and (not (regexp-lock-syntactic-face-p face))
1140                        (save-excursion
1141                          (condition-case nil
1142                              (progn
1143                                (setq from (match-beginning 0))
1144                                (goto-char from)
1145                                (forward-sexp)
1146                                (setq to (point)))
1147                            (error nil)))
1148                        (goto-char from)
1149                        (re-search-forward
1150                         (concat regexp-lock-regexp-string
1151                                 "\\|regexp-opt") to 'to))
1152                   (progn
1153                     (setq lock 2)
1154                     (goto-char (1+ from))
1155                     (throw 'lock nil))
1156                 (goto-char (min (point) bound))))
1157              ((match-beginning 4)
1158               ;; message / error / search- / skip-syntax- / skip-chars-, skip
1159               (if (and (not (regexp-lock-syntactic-face-p face))
1160                        (save-excursion
1161                          (condition-case nil
1162                              (progn
1163                                (goto-char (match-beginning 0))
1164                                (forward-sexp)
1165                                (setq to (point)))
1166                            (error nil))))
1167                   (goto-char (min to bound))
1168                 (goto-char (min (point) bound)))))))))
1169     (when lock (put-text-property from bound 'regexp-lock lock))))
1170
1171
1172 ;; _____________________________________________________________________________
1173 ;;
1174 ;;;                              Overlays
1175 ;; _____________________________________________________________________________
1176 ;;
1177 (defun regexp-lock-show ()
1178   "Display numbers of regular expression groups.
1179
1180
1181 Groups considered are subexpressions enclosed by escaped parentheses
1182 `\\(' and `\\)'.  Shy groups are not counted.  Group numbers overlay one
1183 or both backslashes of any `\\(' and `\\)' of the same regexp with the
1184 number of the group.  Overlays are highlighted whenever `point' is
1185 before the left or after the right parenthesis of an `\\(' or `\\)'.
1186 Hence the group enclosed by `\1(...\1)', for example, represents the
1187 subexpression matching `(match-string 1)'.  Overlays are also shown when
1188 `point' is before a double-quote beginning, or after a double-quote
1189 terminating a string that is part of the regular expression.
1190
1191
1192 Group numbers are displayed whenever Emacs becomes idle after a delay of
1193 `regexp-lock-show-delay' seconds.  Group numbers are highlighted with
1194 `regexp-lock-group' face."
1195   (when regexp-lock-overlays
1196     (dolist (overlay regexp-lock-overlays)
1197       (delete-overlay overlay))
1198     (setq regexp-lock-overlays nil))
1199   (when (and regexp-lock-mode
1200              (not (eq (selected-window) regexp-lock-match-window))
1201              (or (and (< 2 (point))     ; \\^(
1202                       (< (point) (point-max))
1203                       (char-equal (char-after) ?\( )
1204                       (get-text-property (1- (point)) 'regexp-lock)
1205                       (> (get-text-property (1- (point)) 'regexp-lock) 0)
1206                       (char-equal (char-before) ?\\ )
1207                       (char-equal (char-before (1- (point))) ?\\ ))
1208                  (and (< 3 (point))     ; \\)^
1209                       (char-equal (char-before) ?\) )
1210                       (get-text-property (1- (point)) 'regexp-lock)
1211                       (> (get-text-property (1- (point)) 'regexp-lock) 0)
1212                       (char-equal (char-before (1- (point))) ?\\ )
1213                       (char-equal (char-before (- (point) 2)) ?\\ ))
1214                  (and (< (point) (point-max)) ; ^"
1215                       (char-equal (char-after) ?\" )
1216                       (get-text-property (point) 'regexp-lock)
1217                       (regexp-lock-string-face-p
1218                        (get-text-property (point) 'face))
1219                       (or (= (point) (point-min))
1220                           (not (regexp-lock-string-face-p
1221                                 (get-text-property (1- (point)) 'face)))))
1222                  (and (< 3 (point))     ; "^
1223                       (char-equal (char-before) ?\" )
1224                       (get-text-property (1- (point)) 'regexp-lock)
1225                       (regexp-lock-string-face-p
1226                        (get-text-property (1- (point)) 'face))
1227                       (or (= (point) (point-max))
1228                           (not (regexp-lock-string-face-p
1229                                 (get-text-property (point) 'face)))))))
1230     (save-match-data
1231       (save-excursion
1232         (let* ((at (point)) (groups nil) (number 0) (total 0)
1233                (from at) (to at)
1234                (parse-sexp-ignore-comments t))
1235           ;; search beginning and end, tedious
1236           (while (and (> from (point-min))
1237                       (get-text-property (1- from) 'regexp-lock)
1238                       (not (zerop (get-text-property (1- from) 'regexp-lock)))
1239                       (setq from (previous-single-property-change
1240                                   (point) 'regexp-lock nil (point-min)))
1241                       (goto-char from)))
1242           (goto-char at)
1243           (while (and (< to (point-max))
1244                       (get-text-property to 'regexp-lock)
1245                       (setq to (next-single-property-change
1246                                 (point) 'regexp-lock nil (point-max)))
1247                       (goto-char to)))
1248           ;; make overlay for group zero
1249           (let ((overlay (make-overlay from to)))
1250             (overlay-put overlay 'face 'regexp-lock-regexp)
1251             (overlay-put overlay 'window (selected-window))
1252             (overlay-put overlay 'cursor t)
1253             (overlay-put overlay 'priority regexp-lock-show-priority)
1254             (setq regexp-lock-overlays (cons overlay regexp-lock-overlays)))
1255           ;; using a fixed-size vector here would avoid consing but
1256           ;; introduce an upper limit on the number of groupings
1257           (goto-char from)
1258           (while (re-search-forward
1259 "\\(?:\\\\\\\\\\)\\(?:\\(?:\\\\\\\\\\)\\|\\((\\(\\?:\\)?\\)\\|\\()\\)\\)\\|\\(regexp-opt\\)"
1260  to t)
1261             (cond
1262              ((and (match-beginning 4)  ; (regexp-opt ...)
1263                    (not (regexp-lock-syntactic-face-p (match-beginning 4))))
1264               (save-match-data
1265                 (let (at-too)           ; Re-search from here.
1266                   (when (save-excursion
1267                           (goto-char (match-end 4))
1268                           (condition-case nil
1269                               (progn
1270                                 (forward-sexp)
1271                                 (forward-comment (buffer-size))
1272                                 (setq at-too (point))
1273                                 ;; Anything but `nil' and `()' counts as
1274 non-nil.
1275                                 (when (looking-at "\\(?:nil\\|()\\)")
1276                                   (goto-char (match-end 0))
1277                                   (forward-comment (buffer-size)))
1278                                 (and (looking-at "[^)]")))
1279                             (error nil)))
1280                     (setq total (1+ total)))
1281                   (when at-too (goto-char at-too)))))
1282              ((or (not (regexp-lock-string-face-p
1283                         (get-text-property (1- (point)) 'face)))
1284                   (< (get-text-property (1- (point)) 'regexp-lock) 0)))
1285              ((match-beginning 2)       ; \\(?:
1286               (setq groups (cons 0 groups)))
1287              ((match-beginning 1)       ; \\(
1288               (setq number (1+ total))
1289               (setq total (1+ total))
1290               (let* ((number-string (number-to-string number))
1291                      (length (min (length number-string) 2))
1292                      (overlay (make-overlay
1293                                (- (match-beginning 1) length)
1294                                (match-beginning 1))))
1295                 (overlay-put overlay 'display
1296                              (propertize number-string 'face
1297 'regexp-lock-group))
1298                 (overlay-put overlay 'window (selected-window))
1299                 (overlay-put overlay 'cursor t)
1300                 (overlay-put overlay 'priority regexp-lock-show-priority)
1301                 (setq regexp-lock-overlays (cons overlay regexp-lock-overlays)))
1302               (setq groups (cons number groups)))
1303              ((match-beginning 3)       ; \\)
1304               (cond
1305                (groups
1306                 (setq number (car groups))
1307                 (unless (zerop number)
1308                   (let* ((number-string (number-to-string number))
1309                          (length (min (length number-string) 2))
1310                          (overlay (make-overlay
1311                                    (- (match-beginning 3) length)
1312                                    (match-beginning 3))))
1313                     (overlay-put overlay 'display
1314                                  (propertize
1315                                   number-string 'face 'regexp-lock-group))
1316                     (overlay-put overlay 'window (selected-window))
1317                     (overlay-put overlay 'cursor t)
1318                     (overlay-put overlay 'priority regexp-lock-show-priority)
1319                     (setq regexp-lock-overlays
1320                           (cons overlay regexp-lock-overlays))))
1321                 (setq groups (cdr groups)))
1322                (t                       ; no open group, warn
1323                 (let ((overlay (make-overlay (1- (match-end 3)) (match-end 3))))
1324                   (overlay-put overlay 'face font-lock-warning-face)
1325                   (overlay-put overlay 'window (selected-window))
1326                   (overlay-put overlay 'priority regexp-lock-show-priority)
1327                   (setq regexp-lock-overlays
1328                         (cons overlay regexp-lock-overlays))))))))
1329           (when groups
1330             ;; unclosed group, warn
1331             (let ((overlay (make-overlay (1- to) to)))
1332               (overlay-put overlay 'face font-lock-warning-face)
1333               (overlay-put overlay 'window (selected-window))
1334               (overlay-put overlay 'priority regexp-lock-show-priority)
1335               (setq regexp-lock-overlays
1336                     (cons overlay regexp-lock-overlays)))))))))
1337
1338
1339 ;; _____________________________________________________________________________
1340 ;;
1341 ;;;                                  Matching
1342 ;; _____________________________________________________________________________
1343 ;;
1344 (defun regexp-lock-match-pre-command ()
1345   "Remove match overlays."
1346   (when regexp-lock-match-overlays
1347     (dolist (overlay regexp-lock-match-overlays)
1348       (delete-overlay overlay))
1349     (setq regexp-lock-match-overlays nil))
1350   ;; remove ourselves from pre-command-hook
1351   (remove-hook 'pre-command-hook 'regexp-lock-match-pre-command))
1352
1353
1354 (defun regexp-lock-match (direction)
1355   "Highlight expressions matching current regexp."
1356   (interactive)
1357   (unless (and regexp-lock-match-regexp
1358                (memq last-command
1359                      '(regexp-lock-match-next regexp-lock-match-prev)))
1360     (if (or (and (< (point) (point-max))
1361                  (get-text-property (point) 'regexp-lock))
1362             (and (> (point) (point-min))
1363                  (get-text-property (1- (point)) 'regexp-lock)))
1364         (save-match-data
1365           (save-excursion
1366             (let* ((at (point)) (from at) (to at)
1367                    (parse-sexp-ignore-comments t))
1368               ;; search beginning and end, tedious
1369               (while (and (> from (point-min))
1370                           (get-text-property (1- from) 'regexp-lock)
1371                           (not (zerop (get-text-property
1372                                        (1- from) 'regexp-lock)))
1373                           (setq from (previous-single-property-change
1374                                       (point) 'regexp-lock nil (point-min)))
1375                           (goto-char from)))
1376               (goto-char at)
1377               (while (and (< to (point-max))
1378                           (get-text-property to 'regexp-lock)
1379                           (setq to (next-single-property-change
1380                                     (point) 'regexp-lock nil (point-max)))
1381                           (goto-char to)))
1382
1383
1384               (save-restriction
1385                 (narrow-to-region from to)
1386                 (goto-char (point-min))
1387                 (setq regexp-lock-match-regexp
1388                       (condition-case var
1389                           (eval (read (current-buffer)))
1390                         ;; display signal information
1391                         (error (message "%s" var) nil)))))))
1392       (message "No regexp around point")))
1393   (when regexp-lock-match-regexp
1394     (if (and regexp-lock-match-window
1395              (window-live-p regexp-lock-match-window)
1396              (not (eq regexp-lock-match-window (selected-window))))
1397         ;; remember buffer
1398         (setq regexp-lock-match-buffer (window-buffer regexp-lock-match-window))
1399       ;; unless regexp-lock-match-window is a live window different from
1400       ;; the selected one, split the selected window and make the newly
1401       ;; created one the new regexp-lock-match-window
1402       (setq regexp-lock-match-window (split-window))
1403       (if (and (not (eq (window-buffer regexp-lock-match-window)
1404                         regexp-lock-match-buffer))
1405                (buffer-live-p regexp-lock-match-buffer))
1406           ;; when regexp-lock-match-buffer is a live buffer assert that
1407           ;; it is displayed in regexp-lock-match-window
1408           (set-window-buffer
1409            regexp-lock-match-window regexp-lock-match-buffer)
1410         ;; remember buffer
1411         (setq regexp-lock-match-buffer
1412               (window-buffer regexp-lock-match-window))))
1413     (save-match-data
1414       (save-excursion
1415         (with-selected-window regexp-lock-match-window
1416           ;; handle direction changes in an intuitive way
1417           (cond
1418            ((and (eq last-command 'regexp-lock-match-next)
1419                  (< direction 0)
1420                  (eq (marker-buffer regexp-lock-match-from)
1421                      regexp-lock-match-buffer))
1422             ;; use from marker
1423             (goto-char regexp-lock-match-from))
1424            ((and (eq last-command 'regexp-lock-match-prev)
1425                  (> direction 0)
1426                  (eq (marker-buffer regexp-lock-match-to)
1427                      regexp-lock-match-buffer))
1428             ;; use to marker
1429             (goto-char regexp-lock-match-to)))
1430           (let ((at (point))
1431                 bound first)
1432             (catch 'empty
1433               (while (if (< direction 0)
1434                          (re-search-backward regexp-lock-match-regexp bound t)
1435                        (re-search-forward regexp-lock-match-regexp bound t))
1436                 (if (= (match-beginning 0) (match-end 0))
1437                     (progn
1438                       (message "Empty match ...")
1439                       (sit-for 1)
1440                       (throw 'empty nil))
1441                   (let ((overlay (make-overlay
1442                                   (match-beginning 0) (match-end 0)))
1443                         (matches (cddr (match-data)))
1444                         (index 1))
1445                     (setq regexp-lock-match-overlays
1446                           (cons overlay regexp-lock-match-overlays))
1447                     (overlay-put overlay 'face
1448                                  (if first
1449                                      'regexp-lock-match-other
1450                                    'regexp-lock-match))
1451                     (overlay-put overlay 'window regexp-lock-match-window)
1452                     (unless first
1453                       (setq first (point))
1454                       (set-marker regexp-lock-match-from (match-beginning 0))
1455                       (set-marker regexp-lock-match-to (match-end 0))
1456                       (setq bound
1457                             (save-excursion
1458                               (vertical-motion
1459                                (if (< direction 0)
1460                                    (- (window-height))
1461                                  (window-height)))
1462                               (setq bound (point))))
1463                       ;; set pre-command-hook to remove match overlays
1464 eventually
1465                       (add-hook 'pre-command-hook
1466 'regexp-lock-match-pre-command)
1467                       (while matches
1468                         (cond
1469                          ((eq (car matches) nil)
1470                           (setq index (1+ index))
1471                           (setq matches (cddr matches)))
1472                          ((integer-or-marker-p (car matches))
1473                           (setq overlay
1474                                 (make-overlay (car matches) (cadr matches)))
1475                           (overlay-put
1476                            overlay 'before-string
1477                            (propertize (concat regexp-lock-match-before-group
1478                                                (number-to-string index))
1479                                        'face 'regexp-lock-match-group))
1480                           (overlay-put overlay 'priority index)
1481                           (overlay-put overlay 'window regexp-lock-match-window)
1482                           (setq regexp-lock-match-overlays
1483                                 (cons overlay regexp-lock-match-overlays))
1484                           (overlay-put
1485                            overlay 'after-string
1486                            (propertize (concat (number-to-string index)
1487                                                regexp-lock-match-after-group)
1488                                        'face 'regexp-lock-match-group))
1489                           (overlay-put overlay 'priority index)
1490                           (overlay-put overlay 'window regexp-lock-match-window)
1491                           (setq regexp-lock-match-overlays
1492                                 (cons overlay regexp-lock-match-overlays))
1493                           (setq index (1+ index))
1494                           (setq matches (cddr matches)))
1495                          (t (setq matches nil))))))))
1496               (let ((to (or (and first regexp-lock-match-from) at)))
1497                 (save-excursion
1498                   (goto-char to)
1499                   (vertical-motion (- (window-height)))
1500                   (while (re-search-forward regexp-lock-match-regexp to t)
1501                     (cond
1502                      ((= (match-beginning 0) (match-end 0))
1503                       (message "Empty match ...")
1504                       (sit-for 1)
1505                       (throw 'empty nil))
1506                      (t
1507                       (let ((overlay (make-overlay
1508                                       (match-beginning 0) (match-end 0))))
1509                         (setq regexp-lock-match-overlays
1510                               (cons overlay regexp-lock-match-overlays))
1511                         (overlay-put overlay 'face 'regexp-lock-match-other)
1512                         (overlay-put
1513                          overlay 'window regexp-lock-match-window)))))
1514                   (goto-char (or (and first regexp-lock-match-to) to))
1515                   (setq to (save-excursion
1516                              (vertical-motion (window-height))
1517                              (point)))
1518                   (while (re-search-forward regexp-lock-match-regexp to t)
1519                     (cond
1520                      ((= (match-beginning 0) (match-end 0))
1521                       (message "Empty match ...")
1522                       (sit-for 1)
1523                       (throw 'empty nil))
1524                      (t
1525                       (let ((overlay (make-overlay
1526                                       (match-beginning 0) (match-end 0))))
1527                         (setq regexp-lock-match-overlays
1528                               (cons overlay regexp-lock-match-overlays))
1529                         (overlay-put overlay 'face 'regexp-lock-match-other)
1530                         (overlay-put
1531                          overlay 'window regexp-lock-match-window))))))))
1532             (if first
1533                 (progn
1534                   (goto-char first)
1535                   (unless (pos-visible-in-window-p)
1536                     (if (< direction 0)
1537                         (recenter -3)
1538                       (recenter 3))))
1539               (goto-char at)
1540               (set-marker regexp-lock-match-from nil)
1541               (set-marker regexp-lock-match-to nil)
1542               (message "No (more) matches ...")
1543               (sit-for 1))))))))
1544
1545
1546 (defun regexp-lock-match-next ()
1547   "Move to next matching expression."
1548   (interactive)
1549   (if (memq last-command '(regexp-lock-match-next regexp-lock-match-prev))
1550       (regexp-lock-match 1)
1551     (regexp-lock-match 0)))
1552
1553
1554 (defun regexp-lock-match-prev ()
1555   "Move to previous matching expression."
1556   (interactive)
1557   (regexp-lock-match -1))
1558
1559
1560 ;; _____________________________________________________________________________
1561 ;;
1562 ;;;                 Increment / Decrement group numbers
1563 ;; _____________________________________________________________________________
1564 ;;
1565 (defun regexp-lock-increment (above increment start end)
1566   "In-/Decrement group numbers within region.
1567
1568
1569 Within region add INCREMENT to all arguments of `match-beginning',
1570 `match-end', and `match-string' greater or equal ABOVE."
1571   (interactive "nIn-/Decrement group numbers >=: \nnBy: \nr")
1572   (save-excursion
1573     (goto-char start)
1574     (let ((count 0))
1575       (while (re-search-forward
1576               "(match-\\(?:beginning\\|end\\|string\\)[ \t\n\f]+\\([0-9]+\\))"
1577               end t)
1578         (let ((number (string-to-number (match-string 1))))
1579           (when (>= number above)
1580             (replace-match
1581              (number-to-string (+ number increment)) nil nil nil 1)
1582             (setq count (1+ count)))))
1583       (if (zerop count)
1584           (message "No substitutions performed")
1585         (message "%s substitution(s) performed" count)))))
1586
1587
1588 (provide 'regexp-lock)
1589
1590
1591 ;;; regexp-lock.el ends here
1592
1593