1 ;;; auto-overlays.el --- Automatic regexp-delimited overlays
4 ;; Copyright (C) 2005-2015 Free Software Foundation, Inc
7 ;; Author: Toby Cubitt <toby-predictive@dr-qubit.org>
8 ;; Maintainer: Toby Cubitt <toby-predictive@dr-qubit.org>
9 ;; Keywords: extensions
10 ;; URL: http://www.dr-qubit.org/emacs.php
11 ;; Repository: http://www.dr-qubit.org/git/predictive.git
13 ;; This file is part of the Emacs.
15 ;; This file is free software: you can redistribute it and/or modify it under
16 ;; the terms of the GNU General Public License as published by the Free
17 ;; Software Foundation, either version 3 of the License, or (at your option)
20 ;; This program is distributed in the hope that it will be useful, but WITHOUT
21 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
22 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
25 ;; You should have received a copy of the GNU General Public License along
26 ;; with this program. If not, see <http://www.gnu.org/licenses/>.
31 (defvar auto-overlay-regexps nil)
32 (make-variable-buffer-local 'auto-overlay-regexps)
33 (defvar auto-overlay-load-hook nil)
34 (defvar auto-overlay-unload-hook nil)
37 (eval-when-compile (require 'cl))
38 (require 'auto-overlay-common)
39 (provide 'auto-overlays)
42 ;; (defvar auto-overlay-list nil)
43 ;; (make-variable-buffer-local 'auto-overlay-list)
44 (defvar auto-o-pending-updates nil)
45 (make-variable-buffer-local 'auto-o-pending-updates)
46 (defvar auto-o-pending-suicides nil)
47 (make-variable-buffer-local 'auto-o-pending-suicides)
48 (defvar auto-o-pending-pre-suicide nil)
49 (make-variable-buffer-local 'auto-o-pending-pre-suicide)
50 (defvar auto-o-pending-post-suicide nil)
51 (make-variable-buffer-local 'auto-o-pending-post-suicide)
52 (defvar auto-o-pending-post-update nil)
53 (make-variable-buffer-local 'auto-o-pending-post-update)
58 ;;;========================================================
59 ;;; Code-tidying macros
61 (defmacro auto-o-create-set (set-id)
62 ;; Add blank entry for a new regexp set SET-ID to `auto-overlay-regexps'.
63 `(push (list ,set-id nil) auto-overlay-regexps))
66 (defmacro auto-o-delete-set (set-id)
67 ;; Delete SET-ID entry from `auto-overlay-regexps'.
68 `(setq auto-overlay-regexps
69 (assq-delete-all ,set-id auto-overlay-regexps)))
72 (defmacro auto-o-get-full-buffer-list (set-id)
73 ;; Return the list of buffers and associated properties for regexp set
75 `(nth 1 (assq ,set-id auto-overlay-regexps)))
78 (defmacro auto-o-get-buffer-list (set-id)
79 ;; Return list of buffers using regexp set SET-ID.
80 `(mapcar 'car (auto-o-get-full-buffer-list ,set-id)))
83 (defmacro auto-o-get-regexps (set-id)
84 ;; Return the list of regexp definitions for regexp set SET-ID.
85 `(cddr (assq ,set-id auto-overlay-regexps)))
88 ;; (defmacro auto-o-set-regexps (set-id regexps)
89 ;; ;; Set the list of regexp definitions for regexp set SET-ID.
90 ;; `(setcdr (cdr (assq ,set-id auto-overlay-regexps)) ,regexps))
95 ;; (defmacro auto-o-set-buffer-list (set-id list)
96 ;; ;; Set the list of buffers that use the regexp set SET-ID to LIST.
97 ;; `(let ((set (assq ,set-id auto-overlay-regexps)))
98 ;; (and set (setcar (cddr set) ,list))))
101 (defmacro auto-o-add-to-buffer-list (set-id buffer)
102 ;; Add BUFFER to the list of buffers using regexp set SET-ID.
103 `(let ((set (assq ,set-id auto-overlay-regexps)))
105 (null (assq ,buffer (cadr set)))
106 (setcar (cdr set) (cons (cons ,buffer nil) (cadr set))))))
109 (defmacro auto-o-delete-from-buffer-list (set-id buffer)
110 ;; Remove BUFFER from the list of buffers using regexp set SET-ID.
111 `(let ((set (assq ,set-id auto-overlay-regexps)))
113 (setcar (cdr set) (assq-delete-all ,buffer (cadr set))))))
118 (defmacro auto-o-enabled-p (set-id &optional buffer)
119 ;; Return non-nil if regexp set identified by SET-ID is enabled in BUFFER.
120 `(let ((buff (or ,buffer (current-buffer))))
121 (cdr (assq buff (auto-o-get-full-buffer-list ,set-id)))))
124 (defmacro auto-o-enable-set (set-id buffer)
125 ;; Set enabled flag for BUFFER in regexp set SET-ID.
126 `(setcdr (assq ,buffer (auto-o-get-full-buffer-list ,set-id)) t))
129 (defmacro auto-o-disable-set (set-id buffer)
130 ;; Unset enabled flag for BUFFER in regexp set SET-ID.
131 `(setcdr (assq ,buffer (auto-o-get-full-buffer-list ,set-id)) nil))
136 (defmacro auto-o-append-regexp (set-id entry)
137 ;; Append regexp ENTRY to SET-ID's regexps.
138 `(nconc (auto-o-get-regexps ,set-id) (list ,entry)))
141 (defmacro auto-o-prepend-regexp (set-id entry)
142 ;; Prepend regexp ENTRY to SET-ID's regexps.
143 `(setcdr (cdr (assq ,set-id auto-overlay-regexps))
144 (nconc (list ,entry) (auto-o-get-regexps ,set-id))))
147 (defmacro auto-o-insert-regexp (set-id pos entry)
148 ;; Insert regexp ENTRY in SET-ID's regexps at POS.
149 `(setcdr (nthcdr (1- pos) (auto-o-get-regexps ,set-id))
150 (nconc (list ,entry) (nthcdr pos (auto-o-get-regexps ,set-id)))))
154 (defmacro auto-o-entry (set-id definition-id &optional regexp-id)
155 ;; Return regexp entry identified by SET-ID, DEFINITION-ID and REGEXP-ID.
157 (cdr (assq ,regexp-id
158 (cdr (assq ,definition-id
159 (auto-o-get-regexps ,set-id)))))
160 (cdr (assq ,definition-id (cddr (assq ,set-id auto-overlay-regexps))))))
163 (defmacro auto-o-entry-class (set-id definition-id)
164 ;; Return class corresponding to SET-ID and DEFINITION-ID.
165 `(cadr (assq ,definition-id (auto-o-get-regexps ,set-id))))
168 (defmacro auto-o-class (o-match)
169 ;; Return class of match overlay O-MATCH.
170 `(auto-o-entry-class (overlay-get ,o-match 'set-id)
171 (overlay-get ,o-match 'definition-id)))
174 (defmacro auto-o-entry-regexp (set-id definition-id &optional regexp-id)
175 ;; Return regexp corresponsing to SET-ID, DEFINITION-ID and REGEXP-ID.
176 `(let ((regexp (nth 1 (auto-o-entry ,set-id ,definition-id ,regexp-id))))
177 (if (atom regexp) regexp (car regexp))))
180 (defmacro auto-o-regexp (o-match)
181 ;; Return match overlay O-MATCH's regexp.
182 `(auto-o-entry-regexp (overlay-get ,o-match 'set-id)
183 (overlay-get ,o-match 'definition-id)
184 (overlay-get ,o-match 'regexp-id)))
187 (defmacro auto-o-entry-regexp-group (set-id definition-id &optional regexp-id)
188 ;; Return regexp group corresponsing to SET-ID, DEFINITION-ID and REGEXP-ID,
189 ;; or 0 if none is specified.
190 `(let ((regexp (nth 1 (auto-o-entry ,set-id ,definition-id ,regexp-id))))
193 ((atom (cdr regexp)) (cdr regexp))
197 (defmacro auto-o-regexp-group (o-match)
198 ;; Return match overlay O-MATCH's regexp group.
199 `(auto-o-entry-regexp-group (overlay-get ,o-match 'set-id)
200 (overlay-get ,o-match 'definition-id)
201 (overlay-get ,o-match 'regexp-id)))
204 (defmacro auto-o-entry-regexp-group-nth (n set-id definition-id
206 ;; Return Nth regexp group entry corresponsing to SET-ID, DEFINITION-ID and
207 ;; REGEXP-ID, or 0 if there is no Nth entry.
208 `(let ((regexp (nth 1 (auto-o-entry ,set-id ,definition-id ,regexp-id))))
211 ((> (1+ ,n) (length (cdr regexp))) 0)
212 (t (nth ,n (cdr regexp))))))
215 (defmacro auto-o-regexp-group-nth (n o-match)
216 ;; Return match overlay O-MATCH's Nth regexp group entry, or 0 if there is
218 `(auto-o-entry-regexp-group-nth ,n
219 (overlay-get ,o-match 'set-id)
220 (overlay-get ,o-match 'definition-id)
221 (overlay-get ,o-match 'regexp-id)))
224 (defmacro auto-o-entry-props (set-id definition-id &optional regexp-id)
225 ;; Return properties of regexp corresponding to SET-ID, DEFINITION-ID and
227 `(nthcdr 2 (auto-o-entry ,set-id ,definition-id ,regexp-id)))
230 (defmacro auto-o-props (o-match)
231 ;; Return properties associated with match overlay O-MATCH.
232 `(auto-o-entry-props (overlay-get ,o-match 'set-id)
233 (overlay-get ,o-match 'definition-id)
234 (overlay-get ,o-match 'regexp-id)))
237 (defmacro auto-o-entry-edge (set-id definition-id regexp-id)
238 ;; Return edge ('start or 'end) of regexp with SET-ID, DEFINITION-ID and
240 `(car (auto-o-entry ,set-id ,definition-id ,regexp-id)))
243 (defmacro auto-o-edge (o-match)
244 ;; Return edge ('start or 'end) of match overlay O-MATCH
245 `(auto-o-entry-edge (overlay-get ,o-match 'set-id)
246 (overlay-get ,o-match 'definition-id)
247 (overlay-get ,o-match 'regexp-id)))
250 (defmacro auto-o-parse-function (o-match)
251 ;; Return appropriate parse function for match overlay O-MATCH.
252 `(get (auto-o-class ,o-match) 'auto-overlay-parse-function))
255 (defmacro auto-o-suicide-function (o-match)
256 ;; Return appropriate suicide function for match overlay O-MATCH.
257 `(get (auto-o-class ,o-match) 'auto-overlay-suicide-function))
260 (defmacro auto-o-match-function (o-match)
261 ;; Return match function for match overlay O-MATCH, if any.
262 `(get (auto-o-class ,o-match) 'auto-overlay-match-function))
265 (defmacro auto-o-edge-matched-p (overlay edge)
266 ;; test if EDGE of OVERLAY is matched
267 `(overlay-get ,overlay ,edge))
270 (defmacro auto-o-start-matched-p (overlay)
271 ;; test if OVERLAY is start-matched
272 `(overlay-get ,overlay 'start))
275 (defmacro auto-o-end-matched-p (overlay)
276 ;; test if OVERLAY is end-matched
277 `(overlay-get ,overlay 'end))
280 ;; (defmacro auto-o-entry-compound-class-p (set-id definition-id)
281 ;; ;; Return non-nil if regexp corresponding to SET-ID and DEFINITION-ID
282 ;; ;; contains a list of regexp entries rather than a single entry.
283 ;; `(let ((entry (cadr (auto-o-entry ,set-id ,definition-id))))
284 ;; (and (listp entry)
285 ;; (or (symbolp (cdr entry))
286 ;; (and (listp (cdr entry)) (symbolp (cadr entry)))))))
288 ;; (defmacro auto-o-compound-class-p (o-match)
289 ;; ;; Return non-nil if O-MATCH's regexp class is a compound class
290 ;; ;; (can just check for 'regexp-id property instead of checking regexp
291 ;; ;; definitions, since this is always set for such match overlays)
292 ;; `(overlay-get ,o-match 'regexp-id))
295 (defmacro auto-o-entry-complex-class-p (set-id definition-id)
296 ;; Return non-nil if regexp corresponding to SET-ID and DEFINITION-ID
297 ;; requires separate start and end regexps
298 `(get (auto-o-entry-class ,set-id ,definition-id)
299 'auto-overlay-complex-class))
302 (defmacro auto-o-complex-class-p (o-match)
303 ;; Return non-nil if O-MATCH's regexp class is a compound class
304 `(get (auto-o-class ,o-match) 'auto-overlay-complex-class))
308 (defmacro auto-o-rank (o-match)
309 ;; Return the rank of match overlay O-MATCH
310 `(auto-o-assq-position
311 (overlay-get ,o-match 'regexp-id)
312 (cddr (assq (overlay-get ,o-match 'definition-id)
313 (auto-o-get-regexps (overlay-get ,o-match 'set-id))))))
316 (defmacro auto-o-overlay-filename (set-id)
317 ;; Return the default filename to save overlays in
318 `(concat "auto-overlays-"
319 (replace-regexp-in-string
320 "\\." "-" (file-name-nondirectory (or (buffer-file-name)
322 "-" (symbol-name ,set-id)))
327 ;;;============================================================
328 ;;; Replacements for CL functions
330 (defun auto-o-assq-position (key alist)
331 "Find the first association of KEY in ALIST.
332 Return the index of the matching item, or nil of not found.
333 Comparison is done with 'eq."
336 (while (setq el (nth i alist))
337 (when (eq key (car el)) (throw 'found i))
343 (defun auto-o-position (item list)
344 "Find the first occurrence of ITEM in LIST.
345 Return the index of the matching item, or nil of not found.
346 Comparison is done with 'equal."
349 (while (setq el (nth i list))
350 (when (equal item el) (throw 'found i))
356 (defun auto-o-sublist (list start &optional end)
357 "Return the sub-list of LIST from START to END.
358 If END is omitted, it defaults to the length of the list
359 If START or END is negative, it counts from the end."
361 ;; sort out arguments
363 (when (< end 0) (setq end (+ end (setq len (length list)))))
364 (setq end (or len (setq len (length list)))))
366 (setq start (+ start (or len (length list)))))
368 ;; construct sub-list
371 (push (nth start list) res)
372 (setq start (1+ start)))
376 (defmacro auto-o-adjoin (item list)
377 "Cons ITEM onto front of LIST if it's not already there.
378 Comparison is done with `eq'."
379 `(if (memq ,item ,list) ,list (setf ,list (cons ,item ,list))))
383 ;;;=========================================================
384 ;;; auto-overlay definition functions
387 (defun auto-overlay-load-definition (set-id definition &optional pos)
388 "Load DEFINITION into the set of auto-overlay definitions SET-ID
389 in the current buffer. If SET-ID does not exist, it is created.
391 If POS is nil, DEFINITION is added at the end of the list of
392 auto-overlay definitions. If it is t, it is added at the
393 beginning. If it is an integer, it is added at that position in
394 the list. The position in the list makes no difference to the
395 behaviour of the auto-overlays. But it can make a difference to
396 the speed and efficiency. In general, higher-priority and
397 exclusive DEFINITIONS should appear earlier in the list.
399 If DEFINITION-ID is supplied, it should be a symbol that can be
400 used to uniquely identify DEFINITION (see
401 `auto-overlay-unload-definition').
404 DEFINITION should be a list of the form:
406 (CLASS @optional :id DEFINITION-ID @rest REGEXP1 REGEXP2 ... )
408 CLASS is a symbol specifying the auto-overlay class. The standard
409 classes are 'word, 'line, 'self, 'flat and 'nested. The :id
410 property is optional. It should be a symbol that can be used to
411 uniquely identify DEFINITION (see
412 `auto-overlay-unload-definition').
414 The REGEXP's should be lists of the form:
416 (RGXP &optional :edge EDGE :id REGEXP-ID
417 &rest PROPERTY1 PROPERTY2 ... )
419 RGXP is either a single regular expression (a string), or a cons
420 cell of the form (RGXP . GROUP) where RGXP is a regular
421 expression and GROUP is an integer specifying which group in the
422 regular expression forms the delimiter for the auto-overlay. The
423 rest of the PROPERTY entries should be cons cells of the
424 form (NAME . VALUE) where NAME is an overlay property name (a
425 symbol) and VALUE is its value.
427 The properties :edge and :id are optional. The :edge property
428 EDGE should be one of the symbols 'start or 'end. If it is not
429 specified, :edge is assumed to be 'start. The :id property is a
430 symbol that can be used to uniquely identify REGEXP (see
431 `auto-overlay-unload-regexp')."
433 (let ((regexps (auto-o-get-regexps set-id))
434 (class (car definition))
436 ;; if SET-ID doesn't exist in regexp list, create empty set
438 (auto-o-create-set set-id)
439 (auto-o-add-to-buffer-list set-id (current-buffer))
440 (setq regexps (auto-o-get-regexps set-id)))
443 (if (null (setq n (auto-o-position :id definition)))
444 ;; if DEFINITION-ID is not specified, create a unique numeric
448 (mapcar (lambda (elt)
449 (if (integerp (car elt))
452 ;; if DEFINITION-ID is specified, check it's unique
453 (setq definition-id (nth (1+ n) definition))
454 (setq definition (append (auto-o-sublist definition 0 n)
455 (auto-o-sublist definition (+ n 2))))
456 (when (assq definition-id regexps)
457 (error "Definition ID \"%s\" is not unique"
458 (symbol-name definition-id)))
462 ;; adding first entry or at start
463 ((or (eq pos t) (= (length regexps) 0)
464 (and (integerp pos) (<= pos 0)))
465 (auto-o-prepend-regexp set-id (list definition-id class)))
467 ((or (null pos) (and (integerp pos) (>= pos (length regexps))))
468 (auto-o-append-regexp set-id (list definition-id class)))
471 (auto-o-insert-regexp set-id pos (list definition-id class))))
473 ;; load regexp definitions
474 (dolist (regexp (cdr definition))
475 (auto-overlay-load-regexp set-id definition-id regexp))
477 definition-id)) ; return new entry ID
482 (defun auto-overlay-load-regexp (set-id definition-id regexp &optional pos)
483 "Load REGEXP into the auto-overlay definition identified by
484 DEFINITION-ID in the regexp list named SET-ID in the current
487 If POS is nil, REGEXP is added at the end of the definition. If
488 it is t, it is added at the beginning. If it is an integer, it is
489 added at that position.
492 REGEXP should be a list of the form:
494 (RGXP &optional :edge EDGE :id REGEXP-ID
495 &rest PROPERTY1 PROPERTY2 ... )
497 RGXP is either a single regular expression (a string), or a cons
498 cell of the form (RGXP . GROUP) where RGXP is a regular
499 expression and GROUP is an integer specifying which group in the
500 regular expression forms the delimiter for the auto-overlay. The
501 rest of the PROPERTY entries should be cons cells of the
502 form (NAME . VALUE) where NAME is an overlay property name (a
503 symbol) and VALUE is its value.
505 The properties :edge and :id are optional. The :edge property
506 EDGE should be one of the symbols 'start or 'end. If it is not
507 specified, :edge is assumed to be 'start. The :id property is a
508 symbol that can be used to uniquely identify REGEXP (see
509 `auto-overlay-unload-regexp')."
511 (let ((defs (assq definition-id (auto-o-get-regexps set-id)))
512 regexp-id rgxp edge props)
514 (error "Definition \"%s\" not found in auto-overlay regexp set %s"
515 (symbol-name definition-id) (symbol-name set-id)))
518 (setq rgxp (car regexp))
519 (setq regexp (cdr regexp))
522 (if (null (setq n (auto-o-position :edge regexp)))
523 (setq edge 'start) ; assume 'start if unspecified
524 (setq edge (nth (1+ n) regexp))
525 (setq regexp (append (auto-o-sublist regexp 0 n)
526 (auto-o-sublist regexp (+ n 2)))))
528 (if (setq n (auto-o-position :id regexp))
530 (setq regexp-id (nth (1+ n) regexp))
531 (when (assq regexp-id defs)
532 (error "Regexp ID \"%s\" is not unique"
533 (symbol-name regexp-id)))
534 (setq regexp (append (auto-o-sublist regexp 0 n)
535 (auto-o-sublist regexp (+ n 2)))))
536 ;; if no id is specified, create a unique numeric ID
539 (mapcar (lambda (elt)
540 (if (integerp (car elt)) (car elt) -1))
542 ;; extract properties
545 ;; create regexp definition
546 (setq regexp (append (list regexp-id edge rgxp) props))
550 ((or (null pos) (and (integerp pos) (>= pos (length (cddr defs)))))
551 (if (= (length (cddr defs)) 0)
552 (setcdr (cdr defs) (list regexp))
553 (nconc (cddr defs) (list regexp))))
555 ((or (eq pos t) (and (integerp pos) (<= pos 0)))
556 (setcdr (cdr defs) (nconc (list regexp) (cddr defs))))
559 (setcdr (nthcdr (1- pos) (cddr defs))
560 (nconc (list regexp) (nthcdr pos (cddr defs))))))
562 regexp-id)) ; return new subentry ID
566 (defun auto-overlay-unload-set (set-id)
567 "Unload the entire regexp set SET-ID from the current buffer."
569 ;; disable regexp set to delete overlays, then delete regexp set from
571 (when (auto-o-enabled-p set-id)
572 (auto-overlay-stop set-id))
573 (auto-o-delete-from-buffer-list set-id (current-buffer))
574 (auto-o-delete-set set-id))
578 (defun auto-overlay-unload-definition (set-id definition-id)
579 "Unload auto-overlay definition DEFINITION-ID in set SET-ID
580 from the current buffer. Returns the deleted definition."
583 ;; call suicide function for corresponding overlays in all buffers in
584 ;; which the set is enabled
585 (dolist (buff (auto-o-get-buffer-list set-id))
587 (when (auto-o-enabled-p set-id)
588 (mapc (lambda (o) (auto-o-suicide o 'force))
589 (auto-overlays-in (point-min) (point-max)
590 `((eq set-id ,set-id)
591 (eq definition-id ,definition-id))))))
593 (let ((olddef (assq definition-id (auto-o-get-regexps set-id)))
594 def-id class regexps regexp edge regexp-id props)
595 ;; safe to delete by side effect here because definition is guaranteed
596 ;; not to be the first element of the list (the first two elements of a
597 ;; regexp set are always the set-id and the buffer list)
598 (assq-delete-all definition-id (assq set-id auto-overlay-regexps))
601 ;; massage deleted definition into form suitable for
602 ;; `auto-overlay-load-definition'
603 (setq def-id (nth 0 olddef)
605 regexps (nthcdr 2 olddef))
606 (setq olddef (list class :id def-id))
607 (dolist (rgxp regexps)
608 (setq regexp-id (nth 0 rgxp)
611 props (nthcdr 3 rgxp))
614 (list (append (list regexp :edge edge :id regexp-id)
616 olddef))) ; return deleted definition
620 (defun auto-overlay-unload-regexp (set-id definition-id regexp-id)
621 "Unload the regexp identified by REGEXP-ID from auto-overlay
622 definition DEFINITION-ID in set SET-ID of the current buffer.
623 Returns the deleted regexp."
626 ;; call suicide function for corresponding overlays in all buffers in
627 ;; which the set is enabled
628 (dolist (buff (auto-o-get-buffer-list set-id))
630 (when (auto-o-enabled-p set-id)
631 (mapc (lambda (o) (auto-o-suicide o 'force))
632 (auto-overlays-in (point-min) (point-max)
633 `((identity auto-overlay-match)
635 (eq definition-id ,definition-id)
636 (eq regexp-id ,regexp-id))))))
637 ;; delete regexp entry
638 (let* ((def (cdr (assq definition-id (auto-o-get-regexps set-id))))
639 (oldregexp (assq regexp-id def))
640 id edge regexp props)
641 ;; can safely delete by side effect here because the regexp definition
642 ;; is guaranteed not to be the first element of the list (the first two
643 ;; elements of a definition are always the :id and class)
644 (assq-delete-all regexp-id def)
646 ;; massage deleted definition into form suitable for
647 ;; `auto-overlay-load-definition'
648 (setq id (nth 0 oldregexp)
649 edge (nth 1 oldregexp)
650 regexp (nth 2 oldregexp)
651 props (nthcdr 3 oldregexp))
652 (setq oldregexp (append (list regexp :edge edge :id id) props))
653 oldregexp)) ; return deleted regexp
659 (defun auto-overlay-share-regexp-set (set-id from-buffer &optional to-buffer)
660 "Make TO-BUFFER share the regexp set identified by SET-ID with FROM-BUFFER.
661 Any changes to that regexp set in either buffer will be reflected in the
662 other. TO-BUFFER defaults to the current buffer."
664 (unless to-buffer (setq to-buffer (current-buffer)))
666 ;; get regexp set from FROM-BUFFER
667 (with-current-buffer from-buffer
668 (setq regexps (assq set-id auto-overlay-regexps))
669 ;; delete any existing set with same ID, and add regexp set to TO-BUFFER
670 (set-buffer to-buffer)
671 (setq auto-overlay-regexps
672 (assq-delete-all set-id auto-overlay-regexps))
673 (push regexps auto-overlay-regexps)
674 ;; add TO-BUFFER to list of buffers using regexp set SET-ID
675 (auto-o-add-to-buffer-list set-id to-buffer)
680 (defun auto-overlay-start (set-id &optional buffer save-file no-regexp-check)
681 "Activate the set of auto-overlay regexps identified by SET-ID
682 in BUFFER, or the current buffer if none is specified.
684 If optional argument SAVE-FILE is nil, it will try to load the
685 overlays from the default save file if it exists. If SAVE-FILE is
686 a string, it specifies the location of the file (if only a
687 directory is given, it will look for the default filename in that
688 directory). Anything else will cause the save file to be ignored,
689 and the buffer will be reparsed from scratch, as it will be if
690 the save file does not exist.
692 If the overlays are being loaded from a save file, but optional
693 argument NO-REGEXP-CHECK is non-nil, the file of saved overlays
694 will be used, but no check will be made to ensure regexp
695 refinitions are the same as when the overlays were saved."
698 (when buffer (set-buffer buffer))
699 ;; run initialisation hooks
700 (run-hooks 'auto-overlay-load-hook)
701 ;; add hook to run all the various functions scheduled be run after a
702 ;; buffer modification
703 (add-hook 'after-change-functions 'auto-o-run-after-change-functions
705 ;; add hook to schedule an update after a buffer modification
706 (add-hook 'after-change-functions 'auto-o-schedule-update nil t)
707 ;; add hook to simulate missing `delete-in-front-hooks' and
708 ;; `delete-behind-hooks' overlay properties
709 (add-hook 'after-change-functions
710 'auto-o-schedule-delete-in-front-or-behind-suicide nil t)
712 ;; set enabled flag for regexp set, and make sure buffer is in buffer list
713 ;; for the regexp set
714 (auto-o-enable-set set-id (current-buffer))
716 ;; try to load overlays from file
717 (unless (and (or (null save-file) (stringp save-file))
718 (auto-overlay-load-overlays set-id nil save-file
720 ;; if loading was unsuccessful, search for new auto overlays
721 (let ((lines (count-lines (point-min) (point-max))))
722 (goto-char (point-min))
723 (message "Scanning for auto-overlays...(line 1 of %d)"
726 (when (= 9 (mod i 10))
728 "Scanning for auto-overlays...(line %d of %d)"
730 (auto-overlay-update nil nil set-id)
732 (message "Scanning for auto-overlays...done")))
737 (defun auto-overlay-stop (set-id &optional buffer save-file leave-overlays)
738 "Clear all auto-overlays in the set identified by SET-ID
739 from BUFFER, or the current buffer if none is specified.
741 If SAVE-FILE is non-nil and the buffer is associated with a file,
742 save the overlays to a file to speed up loading if the same set
743 of regexp definitions is enabled again. If SAVE-FILE is a string,
744 it specifies the location of the file to save to (if it only
745 specifies a directory, the default filename is used). Anything
746 else will cause the overlays to be saved to the default file name
747 in the current directory.
749 If LEAVE-OVERLAYS is non-nil, don't bother deleting the overlays
750 from the buffer \(this is generally a bad idea, unless the buffer
751 is about to be killed in which case it speeds things up a bit\)."
754 (when buffer (set-buffer buffer))
755 ;; disable overlay set
756 (auto-o-disable-set set-id (current-buffer))
758 ;; if SAVE-FILE is non-nil and buffer is associated with a file, save
761 (unless (stringp save-file) (setq save-file nil))
762 (auto-overlay-save-overlays set-id nil save-file))
764 ;; delete overlays unless told not to bother
765 (unless leave-overlays
766 (mapc 'delete-overlay
768 (point-min) (point-max)
770 (list (lambda (overlay match) (or overlay match))
771 '(auto-overlay auto-overlay-match))
772 (list 'eq 'set-id set-id))
775 ;; if there are no more active auto-overlay definitions...
776 (unless (catch 'enabled
777 (dolist (set auto-overlay-regexps)
778 (when (auto-o-enabled-p (car set))
782 (run-hooks 'auto-overlay-unload-hook)
784 (remove-hook 'after-change-functions 'auto-o-schedule-update t)
785 (remove-hook 'after-change-functions
786 'auto-o-run-after-change-functions t)
787 (setq auto-o-pending-suicides nil
788 auto-o-pending-updates nil
789 auto-o-pending-post-suicide nil))))
793 (defun auto-overlay-save-overlays (set-id &optional buffer file)
794 "Save overlays in set SET-ID in BUFFER to FILE.
795 Defaults to the current buffer.
797 If FILE is nil or a directory, and if the buffer is associated
798 with a file, the filename is constructed from the buffer's file
799 name and SET-ID. The directory is created if necessary. If the
800 buffer is not associated with a file and FILE doesn't specify a
801 filename, an error occurs.
803 The overlays can be loaded again later using
804 `auto-overlay-load-overlays'."
807 (when buffer (set-buffer buffer))
809 ;; construct filename
810 (let ((path (or (and file (file-name-directory file)) ""))
811 (filename (or (and file (file-name-nondirectory file)) "")))
812 ;; use default filename if none supplied
813 (when (string= filename "")
814 (if (buffer-file-name)
815 (setq filename (auto-o-overlay-filename set-id))
816 (error "Can't save overlays to default filename when buffer isn't\
818 ;; create directory if it doesn't exist
819 (make-directory path t)
820 ;; construct full path to file, since that's all we need from now on
821 (setq file (concat path filename)))
823 ;; create temporary buffer
824 (let ((buff (generate-new-buffer " *auto-overlay-save*"))
826 ;; write md5 digests to first two lines
827 (prin1 (md5 (current-buffer)) buff)
829 (prin1 (md5 (prin1-to-string (auto-o-get-regexps set-id))) buff)
832 ;; get sorted list of all match overlays in set SET-ID
834 (auto-overlays-in (point-min) (point-max)
835 (list '(identity auto-overlay-match)
836 (list 'eq 'set-id set-id))))
840 (or (< (overlay-start a) (overlay-start b))
841 (and (= (overlay-start a) (overlay-start b))
842 (> (overlay-end a) (overlay-end b)))))))
844 ;; write overlay data to temporary buffer
846 (prin1 (list (overlay-get o 'definition-id)
847 (overlay-get o 'regexp-id)
850 (marker-position (overlay-get o 'delim-start))
851 (marker-position (overlay-get o 'delim-end)))
856 ;; save the buffer and kill it
857 (with-current-buffer buff (write-file file))
864 (defun auto-overlay-load-overlays (set-id &optional buffer
865 file no-regexp-check)
866 "Load overlays for BUFFER from FILE.
867 Returns t if successful, nil otherwise.
868 Defaults to the current buffer.
870 If FILE is null, or is a string that only specifies a directory,
871 the filename is constructed from the buffer's file name and
872 SET-ID. If the buffer is not associated with a file and FILE
873 doesn't specify a full filename, an error occurs.
875 The FILE should be generated by `auto-overlay-save-overlays'. By
876 default, the buffer contents and regexp definitions for SET-ID
877 will be checked to make sure neither have changed since the
878 overlays were saved. If they don't match, the saved overlay data
879 will not be loaded, and the function will return nil.
881 If NO-REGEXP-CHECK is non-nil, the check for matching regexp
882 definitions will be skipped; the saved overlays will be loaded
883 even if different regexp definitions were active when the
884 overlays were saved."
887 (when buffer (set-buffer buffer))
889 ;; construct filename
890 (let ((path (or (and file (file-name-directory file)) ""))
891 (filename (and file (file-name-nondirectory file))))
892 ;; use default filename if none supplied
893 ;; FIXME: should we throw error if buffer not associated with file?
894 (when (string= filename "")
895 (setq filename (auto-o-overlay-filename set-id)))
896 ;; construct full path to file, since that's all we need from now on
897 (setq file (concat path filename)))
900 ;; return nil if file does not exist
901 (if (not (file-exists-p file))
905 (let ((buff (find-file-noselect file t))
906 md5-buff md5-regexp data o-match o-new lines
909 ;; read md5 digests from first two lines of FILE
910 (with-current-buffer buff (goto-char (point-min)))
911 (setq md5-buff (read buff))
912 (setq md5-regexp (read buff))
915 ;; if saved buffer md5 sum doesn't match buffer contents, or if saved
916 ;; regexp md5 sum doesn't match regexp definitions and checking is not
917 ;; overridden, return nil
918 (if (not (and (string= md5-buff (md5 (current-buffer)))
921 (md5 (prin1-to-string
922 (auto-o-get-regexps set-id)))))))
923 (progn (kill-buffer buff) nil)
925 ;; count number of overlays, for progress message
926 (with-current-buffer buff
927 (setq lines (count-lines (point) (point-max))))
929 ;; read overlay data from FILE until we reach the end
930 (message "Loading auto-overlays...(1 of %d)" lines)
931 (while (condition-case nil (setq data (read buff)) ('end-of-file))
932 ;; create a match overlay corresponding to the data
933 (setq o-match (auto-o-make-match
934 set-id (nth 0 data) (nth 1 data) (nth 2 data)
935 (nth 3 data) (nth 4 data) (nth 5 data)))
936 ;; call the appropriate parse function, unless match overlay is
937 ;; within a higher priority exclusive overlay
938 (unless (auto-o-within-exclusive-p
939 (overlay-get o-match 'delim-start)
940 (overlay-get o-match 'delim-end)
941 (assq 'priority (auto-o-entry-props
942 (overlay-get o-match 'definition-id)
943 (overlay-get o-match 'regexp-id))))
945 (funcall (auto-o-parse-function o-match) o-match))
946 (unless (listp o-new) (setq o-new (list o-new)))
947 ;; give any new overlays some basic properties
949 (overlay-put o 'auto-overlay t)
950 (overlay-put o 'set-id set-id)
951 (overlay-put o 'definition-id
952 (overlay-get o-match 'definition-id))
953 (overlay-put o 'regexp-id
954 (overlay-get o-match 'regexp-id)))
956 ;; run match function if there is one
957 (let ((match-func (auto-o-match-function o-match)))
958 (when match-func (funcall match-func o-match))))
959 ;; display progress message
961 (when (= 0 (mod i 10))
962 (message "Loading auto-overlays...(%d of %d)" i lines)))
965 t))))) ; return t to indicate successful loading)
971 ;;;=============================================================
972 ;;; auto-overlay overlay functions
974 (defun auto-o-run-after-change-functions (beg end len)
975 ;; Assigned to the `after-change-functions' hook. Run all the various
976 ;; functions that should run after a change to the buffer, in the correct
979 ;; ignore changes that aren't either insertions or deletions
980 (when (and (not undo-in-progress)
981 (or (and (/= beg end) (= len 0)) ; insertion
982 (and (= beg end) (/= len 0)))) ; deletion
983 ;; repeat until all the pending functions have been cleared (it may be
984 ;; necessary to run multiple times since the pending functions may
985 ;; themselves cause more functions to be added to the pending lists)
986 (while (or auto-o-pending-pre-suicide auto-o-pending-suicides
987 auto-o-pending-post-suicide auto-o-pending-updates
988 auto-o-pending-post-update)
989 ;; run pending pre-suicide functions
990 (when auto-o-pending-pre-suicide
991 (mapc (lambda (f) (apply (car f) (cdr f)))
992 auto-o-pending-pre-suicide)
993 (setq auto-o-pending-pre-suicide nil))
994 ;; run pending suicides
995 (when auto-o-pending-suicides
996 (mapc 'auto-o-suicide auto-o-pending-suicides)
997 (setq auto-o-pending-suicides nil))
998 ;; run pending post-suicide functions
999 (when auto-o-pending-post-suicide
1000 (mapc (lambda (f) (apply (car f) (cdr f)))
1001 auto-o-pending-post-suicide)
1002 (setq auto-o-pending-post-suicide nil))
1004 (when auto-o-pending-updates
1005 (mapc (lambda (l) (auto-overlay-update (car l) (cdr l)))
1006 auto-o-pending-updates)
1007 (setq auto-o-pending-updates nil))
1008 ;; run pending post-update functions
1009 (when auto-o-pending-post-update
1010 (mapc (lambda (f) (apply (car f) (cdr f)))
1011 auto-o-pending-post-update)
1012 (setq auto-o-pending-post-update nil))
1015 ;; ;; FIXME: horrible hack to delete all marker update entries in latest
1016 ;; ;; `buffer-undo-list' change group, since undoing these can badly
1017 ;; ;; mess up the overlays
1018 ;; (while (and (consp (car buffer-undo-list))
1019 ;; (markerp (caar buffer-undo-list)))
1020 ;; (setq buffer-undo-list (cdr buffer-undo-list)))
1021 ;; (let ((p buffer-undo-list))
1023 ;; (if (and (consp (cadr p)) (markerp (car (cadr p))))
1024 ;; (setcdr p (cddr p))
1025 ;; (setq p (cdr p)))))
1030 (defun auto-o-schedule-update (start &optional end unused set-id)
1031 ;; Schedule `auto-overlay-update' of lines between positions START and END
1032 ;; (including lines containing START and END), optionally restricted to
1033 ;; SET-ID. If END is not supplied, schedule update for just line containing
1034 ;; START. The update will be run by `auto-o-run-after-change-functions'
1035 ;; after buffer modification is complete. This function is assigned to
1036 ;; `after-change-functions'.
1039 (widen) ; need to widen, since goto-line goes to absolute line
1040 (setq start (line-number-at-pos start))
1041 (setq end (if end (line-number-at-pos end) start))
1043 (let ((pending auto-o-pending-updates))
1045 ;; if pending list is empty, just add new entry to the list
1047 (setq auto-o-pending-updates (list (cons start end))))
1049 ;; if start of the new entry is before start of the first entry in
1050 ;; pending list, add new entry to front of the list
1051 ((<= start (caar pending))
1052 (setq auto-o-pending-updates (nconc (list (cons start end)) pending))
1053 (setq pending auto-o-pending-updates))
1057 ;; search for entry in pending list that new one should come after
1058 ;; Note: we do an O(n) linear search here, as opposed to the O(log n)
1059 ;; we would get were we to store the entries in a binary tree. But the
1060 ;; pending list is unlikely to ever be all that long, so the
1061 ;; optimisation almost certainly isn't worth the effort.
1063 (while (cdr pending)
1064 (when (<= start (car (cadr pending))) (throw 'found t))
1065 (setq pending (cdr pending))))
1066 ;; if start of new entry is before end of entry it should come after,
1067 ;; merge it with that entry
1068 (if (<= start (1+ (cdar pending)))
1069 (when (> end (cdar pending)) (setcdr (car pending) end))
1070 ;; otherwise, insert new entry after it
1071 (setcdr pending (nconc (list (cons start end)) (cdr pending)))
1072 (setq pending (cdr pending)))
1075 ;; merge new entry with successive entries until end of merged entry is
1076 ;; before start of next entry (see above note about O(n) vs. O(log n))
1077 (while (and (cdr pending)
1078 (>= (1+ (cdar pending)) (car (cadr pending))))
1079 (setcdr (car pending) (max (cdar pending) (cdr (cadr pending))))
1080 (setcdr pending (cddr pending)))
1085 (defun auto-o-schedule-delete-in-front-or-behind-suicide (start end len)
1086 ;; Schedule `auto-o-suicide' for any overlay that has had characters deleted
1087 ;; in front or behind it, to simulate missing `delete-in-front-hooks' and
1088 ;; `delete-behind-hooks' overlay properties
1090 (dolist (o (auto-overlays-at-point nil '(identity auto-overlay-match)))
1091 (when (or (= (overlay-end o) start) (= (overlay-start o) end))
1092 (auto-o-adjoin o auto-o-pending-suicides)))))
1096 (defun auto-o-schedule-suicide (o-self &optional modified &rest unused)
1097 ;; Schedule `auto-o-suicide' to run after buffer modification is
1098 ;; complete. It will be run by `auto-o-run-after-change-functions'. Assigned
1099 ;; to overlay modification and insert in-front/behind hooks.
1100 (unless modified (auto-o-adjoin o-self auto-o-pending-suicides)))
1104 (defun auto-overlay-update (&optional start end set-id)
1105 ;; Parse lines from line number START to line number END. If only START is
1106 ;; supplied, just parse that line. If neither are supplied, parse line
1107 ;; containing the point. If SET-ID is specified, only look for matches in
1108 ;; that set of overlay regexps definitions.
1112 (let (regexp-entry definition-id class regexp group priority set-id
1113 regexp-id o-match o-overlap o-new)
1114 (unless start (setq start (line-number-at-pos)))
1117 ;; (goto-line start) without messing around with mark and messages
1118 ;; Note: this is a bug in simple.el; there clearly can be a need for
1119 ;; non-interactive calls to goto-line from Lisp code, and
1120 ;; there's no warning about doing this. Yet goto-line *always*
1121 ;; calls push-mark, which usually *shouldn't* be invoked by
1122 ;; Lisp programs, as its docstring warns.
1124 (if (eq selective-display t)
1125 (re-search-forward "[\n\C-m]" nil 'end (1- start))
1126 (forward-line (1- start)))
1128 (dotimes (i (if end (1+ (- end start)) 1))
1130 ;; check each enabled set of overlays, or just the specified set
1131 (dotimes (s (if set-id 1 (length auto-overlay-regexps)))
1132 (setq set-id (or set-id (car (nth s auto-overlay-regexps))))
1133 (when (auto-o-enabled-p set-id)
1135 ;; check each auto-overlay definition in regexp set
1136 (dolist (regexp-entry (auto-o-get-regexps set-id))
1137 (setq definition-id (pop regexp-entry))
1138 (setq class (pop regexp-entry))
1140 ;; check all regexps for current definition
1141 (dotimes (rank (length regexp-entry))
1142 (setq regexp-id (car (nth rank regexp-entry)))
1144 ;; extract regexp properties from current entry
1145 (setq regexp (auto-o-entry-regexp set-id definition-id
1147 (setq group (auto-o-entry-regexp-group
1148 set-id definition-id regexp-id))
1150 (cdr (assq 'priority
1152 set-id definition-id regexp-id))))
1155 ;; look for matches in current line, ensuring case *is*
1158 (while (let ((case-fold-search nil))
1159 (re-search-forward regexp (line-end-position) t))
1160 ;; sanity check regexp definition against match
1161 (when (or (null (match-beginning group))
1162 (null (match-end group)))
1163 (error "Match for regexp \"%s\" has no group %d"
1167 ;; ignore match if it already has a match overlay
1168 ((auto-o-matched-p (match-beginning 0) (match-end 0)
1169 set-id definition-id regexp-id))
1172 ;; if existing match overlay corresponding to same entry
1173 ;; and edge but different subentry overlaps new match...
1175 (auto-o-overlapping-match
1176 (match-beginning group) (match-end group)
1177 set-id definition-id regexp-id
1178 (auto-o-entry-edge set-id definition-id
1180 ;; if new match takes precedence, replace existing one
1181 ;; with new one, otherwise ignore new match
1182 (when (< rank (auto-o-rank o-overlap))
1183 (delete-overlay o-overlap)
1184 (setq o-match (auto-o-make-match
1185 set-id definition-id regexp-id
1186 (match-beginning 0) (match-end 0)
1187 (match-beginning group)
1189 (when (overlay-get o-overlap 'parent)
1190 (auto-o-match-overlay
1191 (overlay-get o-overlap 'parent)
1193 ;; run match function if there is one
1194 (let ((match-func (auto-o-match-function o-match)))
1195 (when match-func (funcall match-func o-match)))))
1197 ;; if match is within a higher priority exclusive
1198 ;; overlay, create match overlay but don't parse it
1199 ((auto-o-within-exclusive-p (match-beginning group)
1202 (auto-o-make-match set-id definition-id regexp-id
1203 (match-beginning 0) (match-end 0)
1204 (match-beginning group)
1208 ;; if we're going to parse the new match...
1210 ;; create a match overlay for it
1211 (setq o-match (auto-o-make-match
1212 set-id definition-id regexp-id
1213 (match-beginning 0) (match-end 0)
1214 (match-beginning group)
1216 ;; call the appropriate parse function
1218 (funcall (auto-o-parse-function o-match) o-match))
1219 (unless (listp o-new) (setq o-new (list o-new)))
1220 ;; give any new overlays some basic properties
1222 (overlay-put o 'auto-overlay t)
1223 (overlay-put o 'set-id set-id)
1224 (overlay-put o 'definition-id definition-id)
1225 (overlay-put o 'regexp-id regexp-id))
1227 ;; run match function if there is one
1228 (let ((match-func (auto-o-match-function o-match)))
1229 (when match-func (funcall match-func o-match)))))
1232 ;; go to character one beyond the start of the match, to
1233 ;; make sure we don't miss the next match (if we find the
1234 ;; same one again, it will just be ignored)
1235 (goto-char (+ (match-beginning 0) 1)))))
1243 (defun auto-o-suicide (o-self &optional force)
1244 ;; This function is assigned to all match overlay modification hooks, and
1245 ;; calls the appropriate suicide function for match overlay O-SELF.
1246 ;; If FORCE is non-nil, O-SELF is deleted irrespective of whether its
1247 ;; overlay still matches.
1249 ;; have to widen temporarily
1252 ;; ;; this condition is here to avoid a weird Emacs bug(?) where the
1253 ;; ;; modification-hooks seem to be called occasionally for overlays that
1254 ;; ;; have already been deleted
1255 ;; (when (overlay-buffer o-self)
1256 ;; if match overlay no longer matches the text it covers...
1257 (unless (and (not force)
1258 (overlay-buffer o-self)
1260 (goto-char (overlay-start o-self))
1261 (looking-at (auto-o-regexp o-self)))
1262 (= (match-end 0) (overlay-end o-self)))
1264 ;; if we have a parent overlay...
1265 (let ((o-parent (overlay-get o-self 'parent))
1268 ;; if our regexp class is a compound class...
1269 (when (auto-o-complex-class-p o-self)
1271 (overlay-get o-parent (if (eq (auto-o-edge o-self) 'start)
1273 ;; if parent's properties have been set by us, remove them
1274 (when (or (null o-other)
1275 (>= (auto-o-rank o-self)
1276 (auto-o-rank o-other)))
1277 (dolist (p (auto-o-props o-self))
1278 (overlay-put o-parent (car p) nil))))
1279 ;; call appropriate suicide function
1280 (funcall (auto-o-suicide-function o-self) o-self)))
1282 ;; schedule an update (necessary since if match regexp contains
1283 ;; "context", we may be comitting suicide only for the match overlay
1284 ;; to be recreated in a slightly different place)
1285 (auto-o-schedule-update (overlay-start o-self))
1287 (delete-overlay o-self));)
1293 (defun auto-o-update-exclusive (set-id beg end old-priority new-priority)
1294 ;; If priority has increased, delete all overlays between BEG end END that
1295 ;; have priority lower than NEW-PRIORITY. If priority has decreased, re-parse
1296 ;; all matches with priority lower than OLD-PRIORITY.
1300 ;; if priority has increased...
1302 (or (null old-priority) (> new-priority old-priority)))
1303 ;; find overlays entirely within BEG and END that are both start and end
1304 ;; matched and have priority lower than NEW-PRIORITY
1308 (list '(identity auto-overlay)
1309 (list 'eq 'set-id set-id)
1311 (list (lambda (definition-id start end)
1312 (or (null (auto-o-entry-complex-class-p
1313 set-id definition-id))
1315 '(definition-id start end))
1316 (list (lambda (pri new) (or (null pri) (< pri new)))
1317 'priority new-priority))
1319 ;; mark overlays in list as inactive (more efficient than calling
1320 ;; suicide functions or deleting the overlays, and leaves them intact in
1321 ;; case the exclusivity of the region is later reduced - see below)
1322 (dolist (o overlay-list) (overlay-put o 'inactive t))
1324 ;; find match overlays between BEG and END that have priority lower then
1325 ;; NEW-PRIORITY but still have an active parent overlay
1329 (list '(identity auto-overlay-match)
1330 (list 'eq 'set-id set-id)
1331 ;; note: parentless overlays are possible if a suicide is
1332 ;; in progress, so need to check overlay has a parent first
1334 (list (lambda (parent)
1335 (not (overlay-get parent 'inactive)))
1337 (list (lambda (set-id definition-id regexp-id new-pri)
1338 (let ((pri (cdr (assq
1341 set-id definition-id regexp-id)))))
1342 (or (null pri) (< pri new-pri))))
1343 '(set-id definition-id regexp-id)
1344 (list new-priority)))))
1345 ;; call appropriate suicide function for each match overlay in list
1346 (dolist (o overlay-list) (funcall (auto-o-suicide-function o) o)))
1349 ;; if priority has decreased...
1351 (or (null new-priority) (< new-priority old-priority)))
1352 ;; find inactive overlays entirely within BEG and END that have priority
1353 ;; higher or equal to NEW-PRIORITY
1357 (list '(identity auto-overlay)
1358 (list 'eq 'set-id set-id)
1359 '(identity inactive)
1360 (list (lambda (pri new) (or (null new) (>= pri new)))
1361 'priority new-priority))
1363 ;; mark overlays in list as active again
1364 (dolist (o overlay-list) (overlay-put o 'inactive nil))
1366 ;; find match overlays between BEG and END that have priority higher or
1367 ;; equal to NEW-PRIORITY but no parent overlay
1371 (list '(identity auto-overlay-match)
1372 (list 'eq 'set-id set-id)
1374 (list (lambda (set-id definition-id regexp-id new-pri)
1375 (let ((pri (cdr (assq
1378 set-id definition-id regexp-id)))))
1379 (or (null new-pri) (>= pri new-pri))))
1380 '(set-id definition-id regexp-id)
1381 (list new-priority)))))
1382 ;; call appropriate parse function for each match overlay in list
1383 (dolist (o-match overlay-list)
1384 (when (not (auto-o-within-exclusive-p o-match))
1385 (let ((o-new (funcall (auto-o-parse-function o-match) o-match)))
1386 ;; give any new overlays the basic properties and add them to
1387 ;; `auto-overlay-list'
1388 (unless (listp o-new) (setq o-new (list o-new)))
1390 (overlay-put o 'auto-overlay t)
1391 (overlay-put o 'set-id set-id)
1392 (overlay-put o 'definition-id
1393 (overlay-get o-match 'definition-id))
1394 (overlay-put o 'regexp-id
1395 (overlay-get o-match 'regexp-id)))
1402 (defun auto-o-make-match (set-id definition-id regexp-id start end
1403 &optional delim-start delim-end)
1404 ;; Create a new match overlay and give it the appropriate properties.
1405 (let ((o-match (make-overlay start end nil 'front-advance nil)))
1406 (overlay-put o-match 'auto-overlay-match t)
1407 (overlay-put o-match 'set-id set-id)
1408 (overlay-put o-match 'definition-id definition-id)
1409 (overlay-put o-match 'regexp-id regexp-id)
1410 (overlay-put o-match 'delim-start
1411 (set-marker (make-marker)
1412 (if delim-start delim-start start)))
1413 (overlay-put o-match 'delim-end
1414 (set-marker (make-marker)
1415 (if delim-end delim-end end)))
1416 (set-marker-insertion-type (overlay-get o-match 'delim-start) t)
1417 (set-marker-insertion-type (overlay-get o-match 'delim-end) nil)
1418 (overlay-put o-match 'modification-hooks '(auto-o-schedule-suicide))
1419 (overlay-put o-match 'insert-in-front-hooks '(auto-o-schedule-suicide))
1420 (overlay-put o-match 'insert-behind-hooks '(auto-o-schedule-suicide))
1421 ;; return the new match overlay
1427 (defun auto-o-match-overlay (overlay start &optional end
1428 no-props no-parse protect-match)
1429 "Match start and end of OVERLAY with START and END match overlays.
1430 If START or END are numbers or markers, move that edge to the
1431 buffer location specified by the number or marker and make it
1432 unmatched. If START or END are non-nil but neither of the above,
1433 make that edge unmatched. If START or END are null, don't change
1434 that edge. However, if END is null, and START is an 'end overlay,
1435 match end of OVERLAY rather than start.
1437 If NO-PARSE is non-nil, block re-parsing due to exclusive overlay
1438 changes. If NO-PROPS is non-nil, block updating of overlay's
1439 properties. If PROTECT-MATCH is non-nil, don't modify any match
1440 overlays associated with OVERLAY (i.e. don't modify their 'parent
1443 (let ((old-start (overlay-start overlay))
1444 (old-end (overlay-end overlay))
1445 (old-o-start (overlay-get overlay 'start))
1446 (old-o-end (overlay-get overlay 'end))
1447 (old-exclusive (overlay-get overlay 'exclusive))
1448 (old-priority (overlay-get overlay 'priority)))
1450 ;; if END is null, we're not unmatching, and START is an end overlay,
1451 ;; match end of overlay instead of start (Note: assumes we're matching an
1452 ;; overlay class with 'start and 'end regexps)
1453 (when (and (null end) (overlayp start) (eq (auto-o-edge start) 'end))
1458 ;; move overlay to new location
1459 (move-overlay overlay
1461 ((overlayp start) (overlay-get start 'delim-end))
1462 ((number-or-marker-p start) start)
1464 (t (overlay-start overlay)))
1466 ((overlayp end) (overlay-get end 'delim-start))
1467 ((number-or-marker-p end) end)
1469 (t (overlay-end overlay))))
1471 ;; if changing start match...
1473 ;; sort out parent property of old start match
1474 (when (and old-o-start (not (eq old-o-start end)) (null protect-match))
1475 (overlay-put old-o-start 'parent nil))
1476 ;; if unmatching start, set start property to nil
1477 (if (not (overlayp start))
1478 (overlay-put overlay 'start nil)
1479 ;; if matching start, set start property to new start match
1480 (overlay-put overlay 'start start)
1481 (overlay-put start 'parent overlay)))
1483 ;; if changing end match...
1485 ;; sort out parent property of old end match
1486 (when (and old-o-end (not (eq old-o-end start)) (null protect-match))
1487 (overlay-put old-o-end 'parent nil))
1488 ;; if unmatching end, set end property to nil
1489 (if (not (overlayp end))
1490 (overlay-put overlay 'end nil)
1491 ;; if matching end, set end property to new end match
1492 (overlay-put overlay 'end end)
1493 (overlay-put end 'parent overlay)))
1496 ;; unless it's blocked, update properties if new match takes precedence
1497 ;; (Note: this sometimes sets the overlay's properties to the ones it
1498 ;; already had, but it hardly seems worth checking for that)
1500 ;; when start was previously matched and is being changed, remove
1501 ;; properties due to old start match
1502 ;; Note: no need to check if properties were really set by start match,
1503 ;; since if not they will be recreated below
1504 (when (and start old-o-start)
1505 (dolist (p (auto-o-props old-o-start))
1506 (overlay-put overlay (car p) nil)))
1507 ;; when end was previously matched and is being changed, remove
1508 ;; properties due to old end match (see note above)
1509 (when (and end old-o-end)
1510 (dolist (p (auto-o-props old-o-end))
1511 (overlay-put overlay (car p) nil)))
1512 ;; sort out properties due to new matches
1515 ;; if start has been unmatched, use properties of end match
1516 ((not (auto-o-start-matched-p overlay))
1517 (setq props (auto-o-props (overlay-get overlay 'end))))
1518 ;; if end has been unmatched, use properties of start match
1519 ((not (auto-o-end-matched-p overlay))
1520 (setq props (auto-o-props (overlay-get overlay 'start))))
1521 (t ;; otherwise, use properties of whichever match takes precedence
1522 (let ((o-start (overlay-get overlay 'start))
1523 (o-end (overlay-get overlay 'end)))
1524 (if (<= (auto-o-rank o-start)
1525 (auto-o-rank o-end))
1526 (setq props (auto-o-props o-start))
1527 (setq props (auto-o-props o-end))))))
1528 ;; bundle properties inside a list if not already, then update them
1529 (when (symbolp (car props)) (setq props (list props)))
1530 (dolist (p props) (overlay-put overlay (car p) (cdr p)))))
1533 ;; unless it's blocked or overlay is inactive, check if anything needs
1534 ;; reparsing due to exclusive overlay changes
1535 (unless (or no-parse (overlay-get overlay 'inactive))
1536 (let ((set-id (overlay-get overlay 'set-id))
1537 (start (overlay-start overlay))
1538 (end (overlay-end overlay))
1539 (exclusive (overlay-get overlay 'exclusive))
1540 (priority (overlay-get overlay 'priority)))
1543 ;; if overlay wasn't and still isn't exclusive, do nothing
1544 ((and (null exclusive) (null old-exclusive)))
1546 ;; if overlay has become exclusive, delete lower priority overlays
1548 ((and (null old-exclusive) exclusive)
1549 (auto-o-update-exclusive set-id start end nil priority))
1551 ;; if overlay was exclusive but no longer is, re-parse region it
1553 ((and old-exclusive (null exclusive))
1554 (auto-o-update-exclusive set-id old-start old-end old-priority nil))
1556 ;; if overlay was and is exclusive, and has been moved to a
1557 ;; completely different location re-parse old location and delete
1558 ;; lower priority overlays within new location
1559 ((or (< end old-start) (> start old-start))
1560 (auto-o-update-exclusive set-id start end old-priority nil)
1561 (auto-o-update-exclusive set-id start end nil priority))
1563 ;; if overlay was and is exclusive, and overlaps its old location...
1565 ;; if priority has changed, re-parse/delete in overlap region
1566 (when (/= old-priority priority)
1567 (auto-o-update-exclusive set-id
1568 (max start old-start) (min end old-end)
1569 old-priority priority))
1571 ;; if overlay was exclusive and start has shrunk, re-parse
1573 ((and (> start old-start) old-exclusive)
1574 (auto-o-update-exclusive set-id old-start start old-priority nil))
1575 ;; if overlay is exclusive and has grown, delete lower priority
1576 ;; overlays in newly covered region
1577 ((and (< start old-start) exclusive)
1578 (auto-o-update-exclusive set-id start old-start nil priority)))
1580 ;; if overlay was exclusive and end has shrunk, re-parse
1581 ((and (< end old-end) old-exclusive)
1582 (auto-o-update-exclusive set-id end old-end old-priority nil))
1583 ;; if overlay is exclusive and has grown, delete lower priority
1584 ((and (> end old-end) exclusive)
1585 (auto-o-update-exclusive set-id old-end end nil priority))))
1592 (defun auto-o-delete-overlay (overlay &optional no-parse protect-match)
1593 "Delete OVERLAY from buffer.
1595 If PROTECT-MATCH is non-nil, don't modify any match overlays
1596 associated with OVERLAY (i.e. leave their 'parent properties
1597 alone). If NO-PARSE is non-nil, block re-parsing due to exclusive
1600 (let ((start (overlay-start overlay))
1601 (end (overlay-end overlay))
1603 ;; delete overlay from buffer and `auto-overlay-list'
1604 (delete-overlay overlay)
1605 (unless (setq o-match (overlay-get overlay 'start))
1606 (setq o-match (overlay-get overlay 'end)))
1607 ;; (auto-o-delete-from-overlay-list overlay)
1609 ;; unless blocked, if overlay's exclusive flag was set, re-parse region it
1611 (when (and (null no-parse) (overlay-get overlay 'exclusive))
1612 (auto-o-update-exclusive (overlay-get overlay 'set-id) start end
1613 (overlay-get overlay 'priority) nil))
1615 ;; Note: it's vital that the match overlays' parent properties are only
1616 ;; set to nil *after* `auto-update-exclusive' is run: if the overlay
1617 ;; overlapped one of its match overlays, the newly parentless match
1618 ;; overlay would be re-parsed by `auto-update-exclusive', which would
1619 ;; re-create the parent overlay that's just been deleted!
1621 ;; unmatch match overlays
1622 (unless protect-match
1623 (when (setq o-match (overlay-get overlay 'start))
1624 (overlay-put o-match 'parent nil))
1625 (when (setq o-match (overlay-get overlay 'end))
1626 (overlay-put o-match 'parent nil)))
1632 (defun auto-o-matched-p (beg end set-id definition-id &optional regexp-id)
1633 ;; Determine if characters between BEG end END are already matched by a
1634 ;; match overlay corresponding to DEFINITION-ID (and optionally REGEXP-ID)
1635 ;; of regexp set SET-ID.
1639 (when (and (overlay-get o 'auto-overlay-match)
1640 (eq (overlay-get o 'set-id) set-id)
1641 (eq (overlay-get o 'definition-id) definition-id)
1642 (eq (overlay-get o 'regexp-id) regexp-id)
1643 (= (overlay-start o) beg)
1644 (= (overlay-end o) end))
1647 (overlays-in beg end)))
1653 (defun auto-o-within-exclusive-p (match &optional end priority)
1654 ;; If MATCH is an overlay, determine if it is within a higher priority
1655 ;; exclusive overlay. If MATCH is a number or marker, determine whether
1656 ;; region between MATCH and END is within an exclusive overlay with higher
1657 ;; priority than PRIORITY.
1660 (setq end (overlay-get match 'delim-end))
1661 (setq priority (overlay-get match 'priority))
1662 (setq match (overlay-get match 'delim-start)))
1664 ;; look for higher priority exclusive overlays
1667 (list '(identity auto-overlay)
1668 '(identity exclusive)
1669 (list (lambda (p q) (and p (or (null q) (> p q))))
1670 'priority priority)))
1676 (defun auto-o-overlapping-match (beg end set-id definition-id regexp-id edge)
1677 ;; Returns any match overlay corresponding to same SET-ID, DEFINITION-ID and
1678 ;; EDGE but different REGEXP-ID whose delimiter overlaps region from BEG to
1679 ;; END. (Only returns first one it finds; which is returned if more than one
1680 ;; exists is undefined.)
1684 (when (and (overlay-get o 'auto-overlay-match)
1685 (eq (overlay-get o 'set-id) set-id)
1686 (eq (overlay-get o 'definition-id) definition-id)
1687 (not (eq (overlay-get o 'regexp-id) regexp-id))
1688 (eq (auto-o-edge o) edge)
1689 ;; check delimiter (not just o) overlaps BEG to END
1690 (< (overlay-get o 'delim-start) end)
1691 (> (overlay-get o 'delim-end) beg))
1694 (overlays-in beg end)))
1700 ;;; ===============================================================
1701 ;;; Compatibility Stuff
1703 (unless (fboundp 'line-number-at-pos)
1704 (require 'auto-overlays-compat)
1705 (defalias 'line-number-at-pos
1706 'auto-overlays-compat-line-number-at-pos))
1709 (unless (fboundp 'replace-regexp-in-string)
1710 (require 'auto-overlays-compat)
1711 (defalias 'replace-regexp-in-string
1712 'auto-overlays-compat-replace-regexp-in-string))
1714 ;;; auto-overlays.el ends here