--- /dev/null
+;;; auto-overlays.el --- Automatic regexp-delimited overlays
+
+
+;; Copyright (C) 2005-2015 Free Software Foundation, Inc
+
+;; Version: 0.10.8
+;; Author: Toby Cubitt <toby-predictive@dr-qubit.org>
+;; Maintainer: Toby Cubitt <toby-predictive@dr-qubit.org>
+;; Keywords: extensions
+;; URL: http://www.dr-qubit.org/emacs.php
+;; Repository: http://www.dr-qubit.org/git/predictive.git
+
+;; This file is part of the Emacs.
+;;
+;; This file is free software: you can redistribute it and/or modify it under
+;; the terms of the GNU General Public License as published by the Free
+;; Software Foundation, either version 3 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but WITHOUT
+;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+;; more details.
+;;
+;; You should have received a copy of the GNU General Public License along
+;; with this program. If not, see <http://www.gnu.org/licenses/>.
+
+
+;;; Code:
+
+(defvar auto-overlay-regexps nil)
+(make-variable-buffer-local 'auto-overlay-regexps)
+(defvar auto-overlay-load-hook nil)
+(defvar auto-overlay-unload-hook nil)
+
+
+(eval-when-compile (require 'cl))
+(require 'auto-overlay-common)
+(provide 'auto-overlays)
+
+
+;; (defvar auto-overlay-list nil)
+;; (make-variable-buffer-local 'auto-overlay-list)
+(defvar auto-o-pending-updates nil)
+(make-variable-buffer-local 'auto-o-pending-updates)
+(defvar auto-o-pending-suicides nil)
+(make-variable-buffer-local 'auto-o-pending-suicides)
+(defvar auto-o-pending-pre-suicide nil)
+(make-variable-buffer-local 'auto-o-pending-pre-suicide)
+(defvar auto-o-pending-post-suicide nil)
+(make-variable-buffer-local 'auto-o-pending-post-suicide)
+(defvar auto-o-pending-post-update nil)
+(make-variable-buffer-local 'auto-o-pending-post-update)
+
+
+
+
+;;;========================================================
+;;; Code-tidying macros
+
+(defmacro auto-o-create-set (set-id)
+ ;; Add blank entry for a new regexp set SET-ID to `auto-overlay-regexps'.
+ `(push (list ,set-id nil) auto-overlay-regexps))
+
+
+(defmacro auto-o-delete-set (set-id)
+ ;; Delete SET-ID entry from `auto-overlay-regexps'.
+ `(setq auto-overlay-regexps
+ (assq-delete-all ,set-id auto-overlay-regexps)))
+
+
+(defmacro auto-o-get-full-buffer-list (set-id)
+ ;; Return the list of buffers and associated properties for regexp set
+ ;; SET-ID.
+ `(nth 1 (assq ,set-id auto-overlay-regexps)))
+
+
+(defmacro auto-o-get-buffer-list (set-id)
+ ;; Return list of buffers using regexp set SET-ID.
+ `(mapcar 'car (auto-o-get-full-buffer-list ,set-id)))
+
+
+(defmacro auto-o-get-regexps (set-id)
+ ;; Return the list of regexp definitions for regexp set SET-ID.
+ `(cddr (assq ,set-id auto-overlay-regexps)))
+
+
+;; (defmacro auto-o-set-regexps (set-id regexps)
+;; ;; Set the list of regexp definitions for regexp set SET-ID.
+;; `(setcdr (cdr (assq ,set-id auto-overlay-regexps)) ,regexps))
+
+
+
+
+;; (defmacro auto-o-set-buffer-list (set-id list)
+;; ;; Set the list of buffers that use the regexp set SET-ID to LIST.
+;; `(let ((set (assq ,set-id auto-overlay-regexps)))
+;; (and set (setcar (cddr set) ,list))))
+
+
+(defmacro auto-o-add-to-buffer-list (set-id buffer)
+ ;; Add BUFFER to the list of buffers using regexp set SET-ID.
+ `(let ((set (assq ,set-id auto-overlay-regexps)))
+ (and set
+ (null (assq ,buffer (cadr set)))
+ (setcar (cdr set) (cons (cons ,buffer nil) (cadr set))))))
+
+
+(defmacro auto-o-delete-from-buffer-list (set-id buffer)
+ ;; Remove BUFFER from the list of buffers using regexp set SET-ID.
+ `(let ((set (assq ,set-id auto-overlay-regexps)))
+ (and set
+ (setcar (cdr set) (assq-delete-all ,buffer (cadr set))))))
+
+
+
+
+(defmacro auto-o-enabled-p (set-id &optional buffer)
+ ;; Return non-nil if regexp set identified by SET-ID is enabled in BUFFER.
+ `(let ((buff (or ,buffer (current-buffer))))
+ (cdr (assq buff (auto-o-get-full-buffer-list ,set-id)))))
+
+
+(defmacro auto-o-enable-set (set-id buffer)
+ ;; Set enabled flag for BUFFER in regexp set SET-ID.
+ `(setcdr (assq ,buffer (auto-o-get-full-buffer-list ,set-id)) t))
+
+
+(defmacro auto-o-disable-set (set-id buffer)
+ ;; Unset enabled flag for BUFFER in regexp set SET-ID.
+ `(setcdr (assq ,buffer (auto-o-get-full-buffer-list ,set-id)) nil))
+
+
+
+
+(defmacro auto-o-append-regexp (set-id entry)
+ ;; Append regexp ENTRY to SET-ID's regexps.
+ `(nconc (auto-o-get-regexps ,set-id) (list ,entry)))
+
+
+(defmacro auto-o-prepend-regexp (set-id entry)
+ ;; Prepend regexp ENTRY to SET-ID's regexps.
+ `(setcdr (cdr (assq ,set-id auto-overlay-regexps))
+ (nconc (list ,entry) (auto-o-get-regexps ,set-id))))
+
+
+(defmacro auto-o-insert-regexp (set-id pos entry)
+ ;; Insert regexp ENTRY in SET-ID's regexps at POS.
+ `(setcdr (nthcdr (1- pos) (auto-o-get-regexps ,set-id))
+ (nconc (list ,entry) (nthcdr pos (auto-o-get-regexps ,set-id)))))
+
+
+
+(defmacro auto-o-entry (set-id definition-id &optional regexp-id)
+ ;; Return regexp entry identified by SET-ID, DEFINITION-ID and REGEXP-ID.
+ `(if ,regexp-id
+ (cdr (assq ,regexp-id
+ (cdr (assq ,definition-id
+ (auto-o-get-regexps ,set-id)))))
+ (cdr (assq ,definition-id (cddr (assq ,set-id auto-overlay-regexps))))))
+
+
+(defmacro auto-o-entry-class (set-id definition-id)
+ ;; Return class corresponding to SET-ID and DEFINITION-ID.
+ `(cadr (assq ,definition-id (auto-o-get-regexps ,set-id))))
+
+
+(defmacro auto-o-class (o-match)
+ ;; Return class of match overlay O-MATCH.
+ `(auto-o-entry-class (overlay-get ,o-match 'set-id)
+ (overlay-get ,o-match 'definition-id)))
+
+
+(defmacro auto-o-entry-regexp (set-id definition-id &optional regexp-id)
+ ;; Return regexp corresponsing to SET-ID, DEFINITION-ID and REGEXP-ID.
+ `(let ((regexp (nth 1 (auto-o-entry ,set-id ,definition-id ,regexp-id))))
+ (if (atom regexp) regexp (car regexp))))
+
+
+(defmacro auto-o-regexp (o-match)
+ ;; Return match overlay O-MATCH's regexp.
+ `(auto-o-entry-regexp (overlay-get ,o-match 'set-id)
+ (overlay-get ,o-match 'definition-id)
+ (overlay-get ,o-match 'regexp-id)))
+
+
+(defmacro auto-o-entry-regexp-group (set-id definition-id &optional regexp-id)
+ ;; Return regexp group corresponsing to SET-ID, DEFINITION-ID and REGEXP-ID,
+ ;; or 0 if none is specified.
+ `(let ((regexp (nth 1 (auto-o-entry ,set-id ,definition-id ,regexp-id))))
+ (cond
+ ((atom regexp) 0)
+ ((atom (cdr regexp)) (cdr regexp))
+ (t (cadr regexp)))))
+
+
+(defmacro auto-o-regexp-group (o-match)
+ ;; Return match overlay O-MATCH's regexp group.
+ `(auto-o-entry-regexp-group (overlay-get ,o-match 'set-id)
+ (overlay-get ,o-match 'definition-id)
+ (overlay-get ,o-match 'regexp-id)))
+
+
+(defmacro auto-o-entry-regexp-group-nth (n set-id definition-id
+ &optional regexp-id)
+ ;; Return Nth regexp group entry corresponsing to SET-ID, DEFINITION-ID and
+ ;; REGEXP-ID, or 0 if there is no Nth entry.
+ `(let ((regexp (nth 1 (auto-o-entry ,set-id ,definition-id ,regexp-id))))
+ (cond
+ ((atom regexp) 0)
+ ((> (1+ ,n) (length (cdr regexp))) 0)
+ (t (nth ,n (cdr regexp))))))
+
+
+(defmacro auto-o-regexp-group-nth (n o-match)
+ ;; Return match overlay O-MATCH's Nth regexp group entry, or 0 if there is
+ ;; no Nth entry.
+ `(auto-o-entry-regexp-group-nth ,n
+ (overlay-get ,o-match 'set-id)
+ (overlay-get ,o-match 'definition-id)
+ (overlay-get ,o-match 'regexp-id)))
+
+
+(defmacro auto-o-entry-props (set-id definition-id &optional regexp-id)
+ ;; Return properties of regexp corresponding to SET-ID, DEFINITION-ID and
+ ;; REGEXP-ID.
+ `(nthcdr 2 (auto-o-entry ,set-id ,definition-id ,regexp-id)))
+
+
+(defmacro auto-o-props (o-match)
+ ;; Return properties associated with match overlay O-MATCH.
+ `(auto-o-entry-props (overlay-get ,o-match 'set-id)
+ (overlay-get ,o-match 'definition-id)
+ (overlay-get ,o-match 'regexp-id)))
+
+
+(defmacro auto-o-entry-edge (set-id definition-id regexp-id)
+ ;; Return edge ('start or 'end) of regexp with SET-ID, DEFINITION-ID and
+ ;; REGEXP-ID
+ `(car (auto-o-entry ,set-id ,definition-id ,regexp-id)))
+
+
+(defmacro auto-o-edge (o-match)
+ ;; Return edge ('start or 'end) of match overlay O-MATCH
+ `(auto-o-entry-edge (overlay-get ,o-match 'set-id)
+ (overlay-get ,o-match 'definition-id)
+ (overlay-get ,o-match 'regexp-id)))
+
+
+(defmacro auto-o-parse-function (o-match)
+ ;; Return appropriate parse function for match overlay O-MATCH.
+ `(get (auto-o-class ,o-match) 'auto-overlay-parse-function))
+
+
+(defmacro auto-o-suicide-function (o-match)
+ ;; Return appropriate suicide function for match overlay O-MATCH.
+ `(get (auto-o-class ,o-match) 'auto-overlay-suicide-function))
+
+
+(defmacro auto-o-match-function (o-match)
+ ;; Return match function for match overlay O-MATCH, if any.
+ `(get (auto-o-class ,o-match) 'auto-overlay-match-function))
+
+
+(defmacro auto-o-edge-matched-p (overlay edge)
+ ;; test if EDGE of OVERLAY is matched
+ `(overlay-get ,overlay ,edge))
+
+
+(defmacro auto-o-start-matched-p (overlay)
+ ;; test if OVERLAY is start-matched
+ `(overlay-get ,overlay 'start))
+
+
+(defmacro auto-o-end-matched-p (overlay)
+ ;; test if OVERLAY is end-matched
+ `(overlay-get ,overlay 'end))
+
+
+;; (defmacro auto-o-entry-compound-class-p (set-id definition-id)
+;; ;; Return non-nil if regexp corresponding to SET-ID and DEFINITION-ID
+;; ;; contains a list of regexp entries rather than a single entry.
+;; `(let ((entry (cadr (auto-o-entry ,set-id ,definition-id))))
+;; (and (listp entry)
+;; (or (symbolp (cdr entry))
+;; (and (listp (cdr entry)) (symbolp (cadr entry)))))))
+
+;; (defmacro auto-o-compound-class-p (o-match)
+;; ;; Return non-nil if O-MATCH's regexp class is a compound class
+;; ;; (can just check for 'regexp-id property instead of checking regexp
+;; ;; definitions, since this is always set for such match overlays)
+;; `(overlay-get ,o-match 'regexp-id))
+
+
+(defmacro auto-o-entry-complex-class-p (set-id definition-id)
+ ;; Return non-nil if regexp corresponding to SET-ID and DEFINITION-ID
+ ;; requires separate start and end regexps
+ `(get (auto-o-entry-class ,set-id ,definition-id)
+ 'auto-overlay-complex-class))
+
+
+(defmacro auto-o-complex-class-p (o-match)
+ ;; Return non-nil if O-MATCH's regexp class is a compound class
+ `(get (auto-o-class ,o-match) 'auto-overlay-complex-class))
+
+
+
+(defmacro auto-o-rank (o-match)
+ ;; Return the rank of match overlay O-MATCH
+ `(auto-o-assq-position
+ (overlay-get ,o-match 'regexp-id)
+ (cddr (assq (overlay-get ,o-match 'definition-id)
+ (auto-o-get-regexps (overlay-get ,o-match 'set-id))))))
+
+
+(defmacro auto-o-overlay-filename (set-id)
+ ;; Return the default filename to save overlays in
+ `(concat "auto-overlays-"
+ (replace-regexp-in-string
+ "\\." "-" (file-name-nondirectory (or (buffer-file-name)
+ (buffer-name))))
+ "-" (symbol-name ,set-id)))
+
+
+
+
+;;;============================================================
+;;; Replacements for CL functions
+
+(defun auto-o-assq-position (key alist)
+ "Find the first association of KEY in ALIST.
+Return the index of the matching item, or nil of not found.
+Comparison is done with 'eq."
+ (let (el (i 0))
+ (catch 'found
+ (while (setq el (nth i alist))
+ (when (eq key (car el)) (throw 'found i))
+ (setq i (1+ i))
+ nil))))
+
+
+
+(defun auto-o-position (item list)
+ "Find the first occurrence of ITEM in LIST.
+Return the index of the matching item, or nil of not found.
+Comparison is done with 'equal."
+ (let (el (i 0))
+ (catch 'found
+ (while (setq el (nth i list))
+ (when (equal item el) (throw 'found i))
+ (setq i (1+ i))
+ nil))))
+
+
+
+(defun auto-o-sublist (list start &optional end)
+ "Return the sub-list of LIST from START to END.
+If END is omitted, it defaults to the length of the list
+If START or END is negative, it counts from the end."
+ (let (len)
+ ;; sort out arguments
+ (if end
+ (when (< end 0) (setq end (+ end (setq len (length list)))))
+ (setq end (or len (setq len (length list)))))
+ (when (< start 0)
+ (setq start (+ start (or len (length list)))))
+
+ ;; construct sub-list
+ (let (res)
+ (while (< start end)
+ (push (nth start list) res)
+ (setq start (1+ start)))
+ (nreverse res))))
+
+
+(defmacro auto-o-adjoin (item list)
+ "Cons ITEM onto front of LIST if it's not already there.
+Comparison is done with `eq'."
+ `(if (memq ,item ,list) ,list (setf ,list (cons ,item ,list))))
+
+
+
+;;;=========================================================
+;;; auto-overlay definition functions
+
+(defun auto-overlay-load-definition (set-id definition &optional pos)
+ "Load DEFINITION into the set of auto-overlay definitions SET-ID
+in the current buffer. If SET-ID does not exist, it is created.
+
+If POS is nil, DEFINITION is added at the end of the list of
+auto-overlay definitions. If it is t, it is added at the
+beginning. If it is an integer, it is added at that position in
+the list. The position in the list makes no difference to the
+behaviour of the auto-overlays. But it can make a difference to
+the speed and efficiency. In general, higher-priority and
+exclusive DEFINITIONS should appear earlier in the list.
+
+If DEFINITION-ID is supplied, it should be a symbol that can be
+used to uniquely identify DEFINITION (see
+`auto-overlay-unload-definition').
+
+
+DEFINITION should be a list of the form:
+
+ (CLASS @optional :id DEFINITION-ID @rest REGEXP1 REGEXP2 ... )
+
+CLASS is a symbol specifying the auto-overlay class. The standard
+classes are 'word, 'line, 'self, 'flat and 'nested. The :id
+property is optional. It should be a symbol that can be used to
+uniquely identify DEFINITION (see
+`auto-overlay-unload-definition').
+
+The REGEXP's should be lists of the form:
+
+ (RGXP &optional :edge EDGE :id REGEXP-ID
+ &rest PROPERTY1 PROPERTY2 ... )
+
+RGXP is either a single regular expression (a string), or a cons
+cell of the form (RGXP . GROUP) where RGXP is a regular
+expression and GROUP is an integer specifying which group in the
+regular expression forms the delimiter for the auto-overlay. The
+rest of the PROPERTY entries should be cons cells of the
+form (NAME . VALUE) where NAME is an overlay property name (a
+symbol) and VALUE is its value.
+
+The properties :edge and :id are optional. The :edge property
+EDGE should be one of the symbols 'start or 'end. If it is not
+specified, :edge is assumed to be 'start. The :id property is a
+symbol that can be used to uniquely identify REGEXP (see
+`auto-overlay-unload-regexp')."
+
+ (let ((regexps (auto-o-get-regexps set-id))
+ (class (car definition))
+ definition-id)
+ ;; if SET-ID doesn't exist in regexp list, create empty set
+ (when (null regexps)
+ (auto-o-create-set set-id)
+ (auto-o-add-to-buffer-list set-id (current-buffer))
+ (setq regexps (auto-o-get-regexps set-id)))
+
+ (let (n)
+ (if (null (setq n (auto-o-position :id definition)))
+ ;; if DEFINITION-ID is not specified, create a unique numeric
+ ;; DEFINITION-ID
+ (setq definition-id
+ (1+ (apply 'max -1
+ (mapcar (lambda (elt)
+ (if (integerp (car elt))
+ (car elt) -1))
+ regexps))))
+ ;; if DEFINITION-ID is specified, check it's unique
+ (setq definition-id (nth (1+ n) definition))
+ (setq definition (append (auto-o-sublist definition 0 n)
+ (auto-o-sublist definition (+ n 2))))
+ (when (assq definition-id regexps)
+ (error "Definition ID \"%s\" is not unique"
+ (symbol-name definition-id)))
+ ))
+
+ (cond
+ ;; adding first entry or at start
+ ((or (eq pos t) (= (length regexps) 0)
+ (and (integerp pos) (<= pos 0)))
+ (auto-o-prepend-regexp set-id (list definition-id class)))
+ ;; adding at end
+ ((or (null pos) (and (integerp pos) (>= pos (length regexps))))
+ (auto-o-append-regexp set-id (list definition-id class)))
+ ;; adding at POS
+ ((integerp pos)
+ (auto-o-insert-regexp set-id pos (list definition-id class))))
+
+ ;; load regexp definitions
+ (dolist (regexp (cdr definition))
+ (auto-overlay-load-regexp set-id definition-id regexp))
+
+ definition-id)) ; return new entry ID
+
+
+
+(defun auto-overlay-load-regexp (set-id definition-id regexp &optional pos)
+ "Load REGEXP into the auto-overlay definition identified by
+DEFINITION-ID in the regexp list named SET-ID in the current
+buffer.
+
+If POS is nil, REGEXP is added at the end of the definition. If
+it is t, it is added at the beginning. If it is an integer, it is
+added at that position.
+
+
+REGEXP should be a list of the form:
+
+ (RGXP &optional :edge EDGE :id REGEXP-ID
+ &rest PROPERTY1 PROPERTY2 ... )
+
+RGXP is either a single regular expression (a string), or a cons
+cell of the form (RGXP . GROUP) where RGXP is a regular
+expression and GROUP is an integer specifying which group in the
+regular expression forms the delimiter for the auto-overlay. The
+rest of the PROPERTY entries should be cons cells of the
+form (NAME . VALUE) where NAME is an overlay property name (a
+symbol) and VALUE is its value.
+
+The properties :edge and :id are optional. The :edge property
+EDGE should be one of the symbols 'start or 'end. If it is not
+specified, :edge is assumed to be 'start. The :id property is a
+symbol that can be used to uniquely identify REGEXP (see
+`auto-overlay-unload-regexp')."
+
+ (let ((defs (assq definition-id (auto-o-get-regexps set-id)))
+ regexp-id rgxp edge props)
+ (when (null defs)
+ (error "Definition \"%s\" not found in auto-overlay regexp set %s"
+ (symbol-name definition-id) (symbol-name set-id)))
+
+ ;; extract regexp
+ (setq rgxp (car regexp))
+ (setq regexp (cdr regexp))
+ (let (n)
+ ;; extract edge
+ (if (null (setq n (auto-o-position :edge regexp)))
+ (setq edge 'start) ; assume 'start if unspecified
+ (setq edge (nth (1+ n) regexp))
+ (setq regexp (append (auto-o-sublist regexp 0 n)
+ (auto-o-sublist regexp (+ n 2)))))
+ ;; extract regexp-id
+ (if (setq n (auto-o-position :id regexp))
+ (progn
+ (setq regexp-id (nth (1+ n) regexp))
+ (when (assq regexp-id defs)
+ (error "Regexp ID \"%s\" is not unique"
+ (symbol-name regexp-id)))
+ (setq regexp (append (auto-o-sublist regexp 0 n)
+ (auto-o-sublist regexp (+ n 2)))))
+ ;; if no id is specified, create a unique numeric ID
+ (setq regexp-id
+ (1+ (apply 'max -1
+ (mapcar (lambda (elt)
+ (if (integerp (car elt)) (car elt) -1))
+ (cddr defs))))))
+ ;; extract properties
+ (setq props regexp))
+
+ ;; create regexp definition
+ (setq regexp (append (list regexp-id edge rgxp) props))
+
+ (cond
+ ;; adding at end
+ ((or (null pos) (and (integerp pos) (>= pos (length (cddr defs)))))
+ (if (= (length (cddr defs)) 0)
+ (setcdr (cdr defs) (list regexp))
+ (nconc (cddr defs) (list regexp))))
+ ;; adding at start
+ ((or (eq pos t) (and (integerp pos) (<= pos 0)))
+ (setcdr (cdr defs) (nconc (list regexp) (cddr defs))))
+ ;; adding at POS
+ ((integerp pos)
+ (setcdr (nthcdr (1- pos) (cddr defs))
+ (nconc (list regexp) (nthcdr pos (cddr defs))))))
+
+ regexp-id)) ; return new subentry ID
+
+
+
+(defun auto-overlay-unload-set (set-id)
+ "Unload the entire regexp set SET-ID from the current buffer."
+
+ ;; disable regexp set to delete overlays, then delete regexp set from
+ ;; current buffer
+ (when (auto-o-enabled-p set-id)
+ (auto-overlay-stop set-id))
+ (auto-o-delete-from-buffer-list set-id (current-buffer))
+ (auto-o-delete-set set-id))
+
+
+
+(defun auto-overlay-unload-definition (set-id definition-id)
+ "Unload auto-overlay definition DEFINITION-ID in set SET-ID
+from the current buffer. Returns the deleted definition."
+
+ (save-excursion
+ ;; call suicide function for corresponding overlays in all buffers in
+ ;; which the set is enabled
+ (dolist (buff (auto-o-get-buffer-list set-id))
+ (set-buffer buff)
+ (when (auto-o-enabled-p set-id)
+ (mapc (lambda (o) (auto-o-suicide o 'force))
+ (auto-overlays-in (point-min) (point-max)
+ `((eq set-id ,set-id)
+ (eq definition-id ,definition-id))))))
+ ;; delete definition
+ (let ((olddef (assq definition-id (auto-o-get-regexps set-id)))
+ def-id class regexps regexp edge regexp-id props)
+ ;; safe to delete by side effect here because definition is guaranteed
+ ;; not to be the first element of the list (the first two elements of a
+ ;; regexp set are always the set-id and the buffer list)
+ (assq-delete-all definition-id (assq set-id auto-overlay-regexps))
+
+
+ ;; massage deleted definition into form suitable for
+ ;; `auto-overlay-load-definition'
+ (setq def-id (nth 0 olddef)
+ class (nth 1 olddef)
+ regexps (nthcdr 2 olddef))
+ (setq olddef (list class :id def-id))
+ (dolist (rgxp regexps)
+ (setq regexp-id (nth 0 rgxp)
+ edge (nth 1 rgxp)
+ regexp (nth 2 rgxp)
+ props (nthcdr 3 rgxp))
+ (setq olddef
+ (append olddef
+ (list (append (list regexp :edge edge :id regexp-id)
+ props)))))
+ olddef))) ; return deleted definition
+
+
+
+(defun auto-overlay-unload-regexp (set-id definition-id regexp-id)
+ "Unload the regexp identified by REGEXP-ID from auto-overlay
+definition DEFINITION-ID in set SET-ID of the current buffer.
+Returns the deleted regexp."
+
+ (save-excursion
+ ;; call suicide function for corresponding overlays in all buffers in
+ ;; which the set is enabled
+ (dolist (buff (auto-o-get-buffer-list set-id))
+ (set-buffer buff)
+ (when (auto-o-enabled-p set-id)
+ (mapc (lambda (o) (auto-o-suicide o 'force))
+ (auto-overlays-in (point-min) (point-max)
+ `((identity auto-overlay-match)
+ (eq set-id ,set-id)
+ (eq definition-id ,definition-id)
+ (eq regexp-id ,regexp-id))))))
+ ;; delete regexp entry
+ (let* ((def (cdr (assq definition-id (auto-o-get-regexps set-id))))
+ (oldregexp (assq regexp-id def))
+ id edge regexp props)
+ ;; can safely delete by side effect here because the regexp definition
+ ;; is guaranteed not to be the first element of the list (the first two
+ ;; elements of a definition are always the :id and class)
+ (assq-delete-all regexp-id def)
+
+ ;; massage deleted definition into form suitable for
+ ;; `auto-overlay-load-definition'
+ (setq id (nth 0 oldregexp)
+ edge (nth 1 oldregexp)
+ regexp (nth 2 oldregexp)
+ props (nthcdr 3 oldregexp))
+ (setq oldregexp (append (list regexp :edge edge :id id) props))
+ oldregexp)) ; return deleted regexp
+)
+
+
+
+(defun auto-overlay-share-regexp-set (set-id from-buffer &optional to-buffer)
+ "Make TO-BUFFER share the regexp set identified by SET-ID with FROM-BUFFER.
+Any changes to that regexp set in either buffer will be reflected in the
+other. TO-BUFFER defaults to the current buffer."
+
+ (unless to-buffer (setq to-buffer (current-buffer)))
+ (let (regexps)
+ ;; get regexp set from FROM-BUFFER
+ (with-current-buffer from-buffer
+ (setq regexps (assq set-id auto-overlay-regexps))
+ ;; delete any existing set with same ID, and add regexp set to TO-BUFFER
+ (set-buffer to-buffer)
+ (setq auto-overlay-regexps
+ (assq-delete-all set-id auto-overlay-regexps))
+ (push regexps auto-overlay-regexps)
+ ;; add TO-BUFFER to list of buffers using regexp set SET-ID
+ (auto-o-add-to-buffer-list set-id to-buffer)
+ )))
+
+
+
+(defun auto-overlay-start (set-id &optional buffer save-file no-regexp-check)
+ "Activate the set of auto-overlay regexps identified by SET-ID
+in BUFFER, or the current buffer if none is specified.
+
+If optional argument SAVE-FILE is nil, it will try to load the
+overlays from the default save file if it exists. If SAVE-FILE is
+a string, it specifies the location of the file (if only a
+directory is given, it will look for the default filename in that
+directory). Anything else will cause the save file to be ignored,
+and the buffer will be reparsed from scratch, as it will be if
+the save file does not exist.
+
+If the overlays are being loaded from a save file, but optional
+argument NO-REGEXP-CHECK is non-nil, the file of saved overlays
+will be used, but no check will be made to ensure regexp
+refinitions are the same as when the overlays were saved."
+
+ (save-excursion
+ (when buffer (set-buffer buffer))
+ ;; run initialisation hooks
+ (run-hooks 'auto-overlay-load-hook)
+ ;; add hook to run all the various functions scheduled be run after a
+ ;; buffer modification
+ (add-hook 'after-change-functions 'auto-o-run-after-change-functions
+ nil t)
+ ;; add hook to schedule an update after a buffer modification
+ (add-hook 'after-change-functions 'auto-o-schedule-update nil t)
+ ;; add hook to simulate missing `delete-in-front-hooks' and
+ ;; `delete-behind-hooks' overlay properties
+ (add-hook 'after-change-functions
+ 'auto-o-schedule-delete-in-front-or-behind-suicide nil t)
+
+ ;; set enabled flag for regexp set, and make sure buffer is in buffer list
+ ;; for the regexp set
+ (auto-o-enable-set set-id (current-buffer))
+
+ ;; try to load overlays from file
+ (unless (and (or (null save-file) (stringp save-file))
+ (auto-overlay-load-overlays set-id nil save-file
+ no-regexp-check))
+ ;; if loading was unsuccessful, search for new auto overlays
+ (let ((lines (count-lines (point-min) (point-max))))
+ (goto-char (point-min))
+ (message "Scanning for auto-overlays...(line 1 of %d)"
+ lines)
+ (dotimes (i lines)
+ (when (= 9 (mod i 10))
+ (message
+ "Scanning for auto-overlays...(line %d of %d)"
+ (+ i 1) lines))
+ (auto-overlay-update nil nil set-id)
+ (forward-line 1))
+ (message "Scanning for auto-overlays...done")))
+ ))
+
+
+
+(defun auto-overlay-stop (set-id &optional buffer save-file leave-overlays)
+ "Clear all auto-overlays in the set identified by SET-ID
+from BUFFER, or the current buffer if none is specified.
+
+If SAVE-FILE is non-nil and the buffer is associated with a file,
+save the overlays to a file to speed up loading if the same set
+of regexp definitions is enabled again. If SAVE-FILE is a string,
+it specifies the location of the file to save to (if it only
+specifies a directory, the default filename is used). Anything
+else will cause the overlays to be saved to the default file name
+in the current directory.
+
+If LEAVE-OVERLAYS is non-nil, don't bother deleting the overlays
+from the buffer \(this is generally a bad idea, unless the buffer
+is about to be killed in which case it speeds things up a bit\)."
+
+ (save-excursion
+ (when buffer (set-buffer buffer))
+ ;; disable overlay set
+ (auto-o-disable-set set-id (current-buffer))
+
+ ;; if SAVE-FILE is non-nil and buffer is associated with a file, save
+ ;; overlays to file
+ (when save-file
+ (unless (stringp save-file) (setq save-file nil))
+ (auto-overlay-save-overlays set-id nil save-file))
+
+ ;; delete overlays unless told not to bother
+ (unless leave-overlays
+ (mapc 'delete-overlay
+ (auto-overlays-in
+ (point-min) (point-max)
+ (list
+ (list (lambda (overlay match) (or overlay match))
+ '(auto-overlay auto-overlay-match))
+ (list 'eq 'set-id set-id))
+ nil 'inactive)))
+
+ ;; if there are no more active auto-overlay definitions...
+ (unless (catch 'enabled
+ (dolist (set auto-overlay-regexps)
+ (when (auto-o-enabled-p (car set))
+ (throw 'enabled t)))
+ nil)
+ ;; run clear hooks
+ (run-hooks 'auto-overlay-unload-hook)
+ ;; reset variables
+ (remove-hook 'after-change-functions 'auto-o-schedule-update t)
+ (remove-hook 'after-change-functions
+ 'auto-o-run-after-change-functions t)
+ (setq auto-o-pending-suicides nil
+ auto-o-pending-updates nil
+ auto-o-pending-post-suicide nil))))
+
+
+
+(defun auto-overlay-save-overlays (set-id &optional buffer file)
+ "Save overlays in set SET-ID in BUFFER to FILE.
+Defaults to the current buffer.
+
+If FILE is nil or a directory, and if the buffer is associated
+with a file, the filename is constructed from the buffer's file
+name and SET-ID. The directory is created if necessary. If the
+buffer is not associated with a file and FILE doesn't specify a
+filename, an error occurs.
+
+The overlays can be loaded again later using
+`auto-overlay-load-overlays'."
+
+ (save-excursion
+ (when buffer (set-buffer buffer))
+
+ ;; construct filename
+ (let ((path (or (and file (file-name-directory file)) ""))
+ (filename (or (and file (file-name-nondirectory file)) "")))
+ ;; use default filename if none supplied
+ (when (string= filename "")
+ (if (buffer-file-name)
+ (setq filename (auto-o-overlay-filename set-id))
+ (error "Can't save overlays to default filename when buffer isn't\
+ visiting a file")))
+ ;; create directory if it doesn't exist
+ (make-directory path t)
+ ;; construct full path to file, since that's all we need from now on
+ (setq file (concat path filename)))
+
+ ;; create temporary buffer
+ (let ((buff (generate-new-buffer " *auto-overlay-save*"))
+ overlay-list)
+ ;; write md5 digests to first two lines
+ (prin1 (md5 (current-buffer)) buff)
+ (terpri buff)
+ (prin1 (md5 (prin1-to-string (auto-o-get-regexps set-id))) buff)
+ (terpri buff)
+
+ ;; get sorted list of all match overlays in set SET-ID
+ (setq overlay-list
+ (auto-overlays-in (point-min) (point-max)
+ (list '(identity auto-overlay-match)
+ (list 'eq 'set-id set-id))))
+ (setq overlay-list
+ (sort overlay-list
+ (lambda (a b)
+ (or (< (overlay-start a) (overlay-start b))
+ (and (= (overlay-start a) (overlay-start b))
+ (> (overlay-end a) (overlay-end b)))))))
+
+ ;; write overlay data to temporary buffer
+ (mapc (lambda (o)
+ (prin1 (list (overlay-get o 'definition-id)
+ (overlay-get o 'regexp-id)
+ (overlay-start o)
+ (overlay-end o)
+ (marker-position (overlay-get o 'delim-start))
+ (marker-position (overlay-get o 'delim-end)))
+ buff)
+ (terpri buff))
+ overlay-list)
+
+ ;; save the buffer and kill it
+ (with-current-buffer buff (write-file file))
+ (kill-buffer buff))
+ ))
+
+
+
+(defun auto-overlay-load-overlays (set-id &optional buffer
+ file no-regexp-check)
+ "Load overlays for BUFFER from FILE.
+Returns t if successful, nil otherwise.
+Defaults to the current buffer.
+
+If FILE is null, or is a string that only specifies a directory,
+the filename is constructed from the buffer's file name and
+SET-ID. If the buffer is not associated with a file and FILE
+doesn't specify a full filename, an error occurs.
+
+The FILE should be generated by `auto-overlay-save-overlays'. By
+default, the buffer contents and regexp definitions for SET-ID
+will be checked to make sure neither have changed since the
+overlays were saved. If they don't match, the saved overlay data
+will not be loaded, and the function will return nil.
+
+If NO-REGEXP-CHECK is non-nil, the check for matching regexp
+definitions will be skipped; the saved overlays will be loaded
+even if different regexp definitions were active when the
+overlays were saved."
+
+ (save-excursion
+ (when buffer (set-buffer buffer))
+
+ ;; construct filename
+ (let ((path (or (and file (file-name-directory file)) ""))
+ (filename (and file (file-name-nondirectory file))))
+ ;; use default filename if none supplied
+ ;; FIXME: should we throw error if buffer not associated with file?
+ (when (string= filename "")
+ (setq filename (auto-o-overlay-filename set-id)))
+ ;; construct full path to file, since that's all we need from now on
+ (setq file (concat path filename)))
+
+
+ ;; return nil if file does not exist
+ (if (not (file-exists-p file))
+ nil
+
+ ;; otherwise...
+ (let ((buff (find-file-noselect file t))
+ md5-buff md5-regexp data o-match o-new lines
+ (i 0))
+
+ ;; read md5 digests from first two lines of FILE
+ (with-current-buffer buff (goto-char (point-min)))
+ (setq md5-buff (read buff))
+ (setq md5-regexp (read buff))
+
+
+ ;; if saved buffer md5 sum doesn't match buffer contents, or if saved
+ ;; regexp md5 sum doesn't match regexp definitions and checking is not
+ ;; overridden, return nil
+ (if (not (and (string= md5-buff (md5 (current-buffer)))
+ (or no-regexp-check
+ (string= md5-regexp
+ (md5 (prin1-to-string
+ (auto-o-get-regexps set-id)))))))
+ (progn (kill-buffer buff) nil)
+
+ ;; count number of overlays, for progress message
+ (with-current-buffer buff
+ (setq lines (count-lines (point) (point-max))))
+
+ ;; read overlay data from FILE until we reach the end
+ (message "Loading auto-overlays...(1 of %d)" lines)
+ (while (condition-case nil (setq data (read buff)) ('end-of-file))
+ ;; create a match overlay corresponding to the data
+ (setq o-match (auto-o-make-match
+ set-id (nth 0 data) (nth 1 data) (nth 2 data)
+ (nth 3 data) (nth 4 data) (nth 5 data)))
+ ;; call the appropriate parse function, unless match overlay is
+ ;; within a higher priority exclusive overlay
+ (unless (auto-o-within-exclusive-p
+ (overlay-get o-match 'delim-start)
+ (overlay-get o-match 'delim-end)
+ (assq 'priority (auto-o-entry-props
+ (overlay-get o-match 'definition-id)
+ (overlay-get o-match 'regexp-id))))
+ (setq o-new
+ (funcall (auto-o-parse-function o-match) o-match))
+ (unless (listp o-new) (setq o-new (list o-new)))
+ ;; give any new overlays some basic properties
+ (mapc (lambda (o)
+ (overlay-put o 'auto-overlay t)
+ (overlay-put o 'set-id set-id)
+ (overlay-put o 'definition-id
+ (overlay-get o-match 'definition-id))
+ (overlay-put o 'regexp-id
+ (overlay-get o-match 'regexp-id)))
+ o-new)
+ ;; run match function if there is one
+ (let ((match-func (auto-o-match-function o-match)))
+ (when match-func (funcall match-func o-match))))
+ ;; display progress message
+ (setq i (1+ i))
+ (when (= 0 (mod i 10))
+ (message "Loading auto-overlays...(%d of %d)" i lines)))
+
+ (kill-buffer buff)
+ t))))) ; return t to indicate successful loading)
+
+
+
+
+
+;;;=============================================================
+;;; auto-overlay overlay functions
+
+(defun auto-o-run-after-change-functions (beg end len)
+ ;; Assigned to the `after-change-functions' hook. Run all the various
+ ;; functions that should run after a change to the buffer, in the correct
+ ;; order.
+
+ ;; ignore changes that aren't either insertions or deletions
+ (when (and (not undo-in-progress)
+ (or (and (/= beg end) (= len 0)) ; insertion
+ (and (= beg end) (/= len 0)))) ; deletion
+ ;; repeat until all the pending functions have been cleared (it may be
+ ;; necessary to run multiple times since the pending functions may
+ ;; themselves cause more functions to be added to the pending lists)
+ (while (or auto-o-pending-pre-suicide auto-o-pending-suicides
+ auto-o-pending-post-suicide auto-o-pending-updates
+ auto-o-pending-post-update)
+ ;; run pending pre-suicide functions
+ (when auto-o-pending-pre-suicide
+ (mapc (lambda (f) (apply (car f) (cdr f)))
+ auto-o-pending-pre-suicide)
+ (setq auto-o-pending-pre-suicide nil))
+ ;; run pending suicides
+ (when auto-o-pending-suicides
+ (mapc 'auto-o-suicide auto-o-pending-suicides)
+ (setq auto-o-pending-suicides nil))
+ ;; run pending post-suicide functions
+ (when auto-o-pending-post-suicide
+ (mapc (lambda (f) (apply (car f) (cdr f)))
+ auto-o-pending-post-suicide)
+ (setq auto-o-pending-post-suicide nil))
+ ;; run updates
+ (when auto-o-pending-updates
+ (mapc (lambda (l) (auto-overlay-update (car l) (cdr l)))
+ auto-o-pending-updates)
+ (setq auto-o-pending-updates nil))
+ ;; run pending post-update functions
+ (when auto-o-pending-post-update
+ (mapc (lambda (f) (apply (car f) (cdr f)))
+ auto-o-pending-post-update)
+ (setq auto-o-pending-post-update nil))
+ ))
+
+ ;; ;; FIXME: horrible hack to delete all marker update entries in latest
+ ;; ;; `buffer-undo-list' change group, since undoing these can badly
+ ;; ;; mess up the overlays
+ ;; (while (and (consp (car buffer-undo-list))
+ ;; (markerp (caar buffer-undo-list)))
+ ;; (setq buffer-undo-list (cdr buffer-undo-list)))
+ ;; (let ((p buffer-undo-list))
+ ;; (while (cadr p)
+ ;; (if (and (consp (cadr p)) (markerp (car (cadr p))))
+ ;; (setcdr p (cddr p))
+ ;; (setq p (cdr p)))))
+ )
+
+
+
+(defun auto-o-schedule-update (start &optional end unused set-id)
+ ;; Schedule `auto-overlay-update' of lines between positions START and END
+ ;; (including lines containing START and END), optionally restricted to
+ ;; SET-ID. If END is not supplied, schedule update for just line containing
+ ;; START. The update will be run by `auto-o-run-after-change-functions'
+ ;; after buffer modification is complete. This function is assigned to
+ ;; `after-change-functions'.
+
+ (save-restriction
+ (widen) ; need to widen, since goto-line goes to absolute line
+ (setq start (line-number-at-pos start))
+ (setq end (if end (line-number-at-pos end) start))
+
+ (let ((pending auto-o-pending-updates))
+ (cond
+ ;; if pending list is empty, just add new entry to the list
+ ((null pending)
+ (setq auto-o-pending-updates (list (cons start end))))
+
+ ;; if start of the new entry is before start of the first entry in
+ ;; pending list, add new entry to front of the list
+ ((<= start (caar pending))
+ (setq auto-o-pending-updates (nconc (list (cons start end)) pending))
+ (setq pending auto-o-pending-updates))
+
+ ;; otherwise...
+ (t
+ ;; search for entry in pending list that new one should come after
+ ;; Note: we do an O(n) linear search here, as opposed to the O(log n)
+ ;; we would get were we to store the entries in a binary tree. But the
+ ;; pending list is unlikely to ever be all that long, so the
+ ;; optimisation almost certainly isn't worth the effort.
+ (catch 'found
+ (while (cdr pending)
+ (when (<= start (car (cadr pending))) (throw 'found t))
+ (setq pending (cdr pending))))
+ ;; if start of new entry is before end of entry it should come after,
+ ;; merge it with that entry
+ (if (<= start (1+ (cdar pending)))
+ (when (> end (cdar pending)) (setcdr (car pending) end))
+ ;; otherwise, insert new entry after it
+ (setcdr pending (nconc (list (cons start end)) (cdr pending)))
+ (setq pending (cdr pending)))
+ ))
+
+ ;; merge new entry with successive entries until end of merged entry is
+ ;; before start of next entry (see above note about O(n) vs. O(log n))
+ (while (and (cdr pending)
+ (>= (1+ (cdar pending)) (car (cadr pending))))
+ (setcdr (car pending) (max (cdar pending) (cdr (cadr pending))))
+ (setcdr pending (cddr pending)))
+ )))
+
+
+
+(defun auto-o-schedule-delete-in-front-or-behind-suicide (start end len)
+ ;; Schedule `auto-o-suicide' for any overlay that has had characters deleted
+ ;; in front or behind it, to simulate missing `delete-in-front-hooks' and
+ ;; `delete-behind-hooks' overlay properties
+ (unless (= len 0)
+ (dolist (o (auto-overlays-at-point nil '(identity auto-overlay-match)))
+ (when (or (= (overlay-end o) start) (= (overlay-start o) end))
+ (auto-o-adjoin o auto-o-pending-suicides)))))
+
+
+
+(defun auto-o-schedule-suicide (o-self &optional modified &rest unused)
+ ;; Schedule `auto-o-suicide' to run after buffer modification is
+ ;; complete. It will be run by `auto-o-run-after-change-functions'. Assigned
+ ;; to overlay modification and insert in-front/behind hooks.
+ (unless modified (auto-o-adjoin o-self auto-o-pending-suicides)))
+
+
+
+(defun auto-overlay-update (&optional start end set-id)
+ ;; Parse lines from line number START to line number END. If only START is
+ ;; supplied, just parse that line. If neither are supplied, parse line
+ ;; containing the point. If SET-ID is specified, only look for matches in
+ ;; that set of overlay regexps definitions.
+
+ (save-restriction
+ (widen)
+ (let (regexp-entry definition-id class regexp group priority set-id
+ regexp-id o-match o-overlap o-new)
+ (unless start (setq start (line-number-at-pos)))
+ (save-excursion
+ (save-match-data
+ ;; (goto-line start) without messing around with mark and messages
+ ;; Note: this is a bug in simple.el; there clearly can be a need for
+ ;; non-interactive calls to goto-line from Lisp code, and
+ ;; there's no warning about doing this. Yet goto-line *always*
+ ;; calls push-mark, which usually *shouldn't* be invoked by
+ ;; Lisp programs, as its docstring warns.
+ (goto-char 1)
+ (if (eq selective-display t)
+ (re-search-forward "[\n\C-m]" nil 'end (1- start))
+ (forward-line (1- start)))
+
+ (dotimes (i (if end (1+ (- end start)) 1))
+
+ ;; check each enabled set of overlays, or just the specified set
+ (dotimes (s (if set-id 1 (length auto-overlay-regexps)))
+ (setq set-id (or set-id (car (nth s auto-overlay-regexps))))
+ (when (auto-o-enabled-p set-id)
+
+ ;; check each auto-overlay definition in regexp set
+ (dolist (regexp-entry (auto-o-get-regexps set-id))
+ (setq definition-id (pop regexp-entry))
+ (setq class (pop regexp-entry))
+
+ ;; check all regexps for current definition
+ (dotimes (rank (length regexp-entry))
+ (setq regexp-id (car (nth rank regexp-entry)))
+
+ ;; extract regexp properties from current entry
+ (setq regexp (auto-o-entry-regexp set-id definition-id
+ regexp-id))
+ (setq group (auto-o-entry-regexp-group
+ set-id definition-id regexp-id))
+ (setq priority
+ (cdr (assq 'priority
+ (auto-o-entry-props
+ set-id definition-id regexp-id))))
+
+
+ ;; look for matches in current line, ensuring case *is*
+ ;; significant
+ (forward-line 0)
+ (while (let ((case-fold-search nil))
+ (re-search-forward regexp (line-end-position) t))
+ ;; sanity check regexp definition against match
+ (when (or (null (match-beginning group))
+ (null (match-end group)))
+ (error "Match for regexp \"%s\" has no group %d"
+ regexp group))
+
+ (cond
+ ;; ignore match if it already has a match overlay
+ ((auto-o-matched-p (match-beginning 0) (match-end 0)
+ set-id definition-id regexp-id))
+
+
+ ;; if existing match overlay corresponding to same entry
+ ;; and edge but different subentry overlaps new match...
+ ((setq o-overlap
+ (auto-o-overlapping-match
+ (match-beginning group) (match-end group)
+ set-id definition-id regexp-id
+ (auto-o-entry-edge set-id definition-id
+ regexp-id)))
+ ;; if new match takes precedence, replace existing one
+ ;; with new one, otherwise ignore new match
+ (when (< rank (auto-o-rank o-overlap))
+ (delete-overlay o-overlap)
+ (setq o-match (auto-o-make-match
+ set-id definition-id regexp-id
+ (match-beginning 0) (match-end 0)
+ (match-beginning group)
+ (match-end group)))
+ (when (overlay-get o-overlap 'parent)
+ (auto-o-match-overlay
+ (overlay-get o-overlap 'parent)
+ o-match))
+ ;; run match function if there is one
+ (let ((match-func (auto-o-match-function o-match)))
+ (when match-func (funcall match-func o-match)))))
+
+ ;; if match is within a higher priority exclusive
+ ;; overlay, create match overlay but don't parse it
+ ((auto-o-within-exclusive-p (match-beginning group)
+ (match-end group)
+ priority)
+ (auto-o-make-match set-id definition-id regexp-id
+ (match-beginning 0) (match-end 0)
+ (match-beginning group)
+ (match-end group)))
+
+
+ ;; if we're going to parse the new match...
+ (t
+ ;; create a match overlay for it
+ (setq o-match (auto-o-make-match
+ set-id definition-id regexp-id
+ (match-beginning 0) (match-end 0)
+ (match-beginning group)
+ (match-end group)))
+ ;; call the appropriate parse function
+ (setq o-new
+ (funcall (auto-o-parse-function o-match) o-match))
+ (unless (listp o-new) (setq o-new (list o-new)))
+ ;; give any new overlays some basic properties
+ (mapc (lambda (o)
+ (overlay-put o 'auto-overlay t)
+ (overlay-put o 'set-id set-id)
+ (overlay-put o 'definition-id definition-id)
+ (overlay-put o 'regexp-id regexp-id))
+ o-new)
+ ;; run match function if there is one
+ (let ((match-func (auto-o-match-function o-match)))
+ (when match-func (funcall match-func o-match)))))
+
+
+ ;; go to character one beyond the start of the match, to
+ ;; make sure we don't miss the next match (if we find the
+ ;; same one again, it will just be ignored)
+ (goto-char (+ (match-beginning 0) 1)))))
+ (forward-line 1))
+ )))
+ ))))
+
+
+
+
+(defun auto-o-suicide (o-self &optional force)
+ ;; This function is assigned to all match overlay modification hooks, and
+ ;; calls the appropriate suicide function for match overlay O-SELF.
+ ;; If FORCE is non-nil, O-SELF is deleted irrespective of whether its
+ ;; overlay still matches.
+
+ ;; have to widen temporarily
+ (save-restriction
+ (widen)
+;; ;; this condition is here to avoid a weird Emacs bug(?) where the
+;; ;; modification-hooks seem to be called occasionally for overlays that
+;; ;; have already been deleted
+;; (when (overlay-buffer o-self)
+ ;; if match overlay no longer matches the text it covers...
+ (unless (and (not force)
+ (overlay-buffer o-self)
+ (save-excursion
+ (goto-char (overlay-start o-self))
+ (looking-at (auto-o-regexp o-self)))
+ (= (match-end 0) (overlay-end o-self)))
+
+ ;; if we have a parent overlay...
+ (let ((o-parent (overlay-get o-self 'parent))
+ o-other)
+ (when o-parent
+ ;; if our regexp class is a compound class...
+ (when (auto-o-complex-class-p o-self)
+ (setq o-other
+ (overlay-get o-parent (if (eq (auto-o-edge o-self) 'start)
+ 'start 'end)))
+ ;; if parent's properties have been set by us, remove them
+ (when (or (null o-other)
+ (>= (auto-o-rank o-self)
+ (auto-o-rank o-other)))
+ (dolist (p (auto-o-props o-self))
+ (overlay-put o-parent (car p) nil))))
+ ;; call appropriate suicide function
+ (funcall (auto-o-suicide-function o-self) o-self)))
+
+ ;; schedule an update (necessary since if match regexp contains
+ ;; "context", we may be comitting suicide only for the match overlay
+ ;; to be recreated in a slightly different place)
+ (auto-o-schedule-update (overlay-start o-self))
+ ;; delete ourselves
+ (delete-overlay o-self));)
+ ))
+
+
+
+
+(defun auto-o-update-exclusive (set-id beg end old-priority new-priority)
+ ;; If priority has increased, delete all overlays between BEG end END that
+ ;; have priority lower than NEW-PRIORITY. If priority has decreased, re-parse
+ ;; all matches with priority lower than OLD-PRIORITY.
+
+ (let (overlay-list)
+ (cond
+ ;; if priority has increased...
+ ((and new-priority
+ (or (null old-priority) (> new-priority old-priority)))
+ ;; find overlays entirely within BEG and END that are both start and end
+ ;; matched and have priority lower than NEW-PRIORITY
+ (setq overlay-list
+ (auto-overlays-in
+ beg end
+ (list '(identity auto-overlay)
+ (list 'eq 'set-id set-id)
+ '(identity start)
+ (list (lambda (definition-id start end)
+ (or (null (auto-o-entry-complex-class-p
+ set-id definition-id))
+ (and start end)))
+ '(definition-id start end))
+ (list (lambda (pri new) (or (null pri) (< pri new)))
+ 'priority new-priority))
+ 'within))
+ ;; mark overlays in list as inactive (more efficient than calling
+ ;; suicide functions or deleting the overlays, and leaves them intact in
+ ;; case the exclusivity of the region is later reduced - see below)
+ (dolist (o overlay-list) (overlay-put o 'inactive t))
+
+ ;; find match overlays between BEG and END that have priority lower then
+ ;; NEW-PRIORITY but still have an active parent overlay
+ (setq overlay-list
+ (auto-overlays-in
+ beg end
+ (list '(identity auto-overlay-match)
+ (list 'eq 'set-id set-id)
+ ;; note: parentless overlays are possible if a suicide is
+ ;; in progress, so need to check overlay has a parent first
+ '(identity parent)
+ (list (lambda (parent)
+ (not (overlay-get parent 'inactive)))
+ 'parent)
+ (list (lambda (set-id definition-id regexp-id new-pri)
+ (let ((pri (cdr (assq
+ 'priority
+ (auto-o-entry-props
+ set-id definition-id regexp-id)))))
+ (or (null pri) (< pri new-pri))))
+ '(set-id definition-id regexp-id)
+ (list new-priority)))))
+ ;; call appropriate suicide function for each match overlay in list
+ (dolist (o overlay-list) (funcall (auto-o-suicide-function o) o)))
+
+
+ ;; if priority has decreased...
+ ((and old-priority
+ (or (null new-priority) (< new-priority old-priority)))
+ ;; find inactive overlays entirely within BEG and END that have priority
+ ;; higher or equal to NEW-PRIORITY
+ (setq overlay-list
+ (auto-overlays-in
+ beg end
+ (list '(identity auto-overlay)
+ (list 'eq 'set-id set-id)
+ '(identity inactive)
+ (list (lambda (pri new) (or (null new) (>= pri new)))
+ 'priority new-priority))
+ 'within 'inactive))
+ ;; mark overlays in list as active again
+ (dolist (o overlay-list) (overlay-put o 'inactive nil))
+
+ ;; find match overlays between BEG and END that have priority higher or
+ ;; equal to NEW-PRIORITY but no parent overlay
+ (setq overlay-list
+ (auto-overlays-in
+ beg end
+ (list '(identity auto-overlay-match)
+ (list 'eq 'set-id set-id)
+ '(null parent)
+ (list (lambda (set-id definition-id regexp-id new-pri)
+ (let ((pri (cdr (assq
+ 'priority
+ (auto-o-entry-props
+ set-id definition-id regexp-id)))))
+ (or (null new-pri) (>= pri new-pri))))
+ '(set-id definition-id regexp-id)
+ (list new-priority)))))
+ ;; call appropriate parse function for each match overlay in list
+ (dolist (o-match overlay-list)
+ (when (not (auto-o-within-exclusive-p o-match))
+ (let ((o-new (funcall (auto-o-parse-function o-match) o-match)))
+ ;; give any new overlays the basic properties and add them to
+ ;; `auto-overlay-list'
+ (unless (listp o-new) (setq o-new (list o-new)))
+ (mapc (lambda (o)
+ (overlay-put o 'auto-overlay t)
+ (overlay-put o 'set-id set-id)
+ (overlay-put o 'definition-id
+ (overlay-get o-match 'definition-id))
+ (overlay-put o 'regexp-id
+ (overlay-get o-match 'regexp-id)))
+ o-new)))))
+ )))
+
+
+
+
+(defun auto-o-make-match (set-id definition-id regexp-id start end
+ &optional delim-start delim-end)
+ ;; Create a new match overlay and give it the appropriate properties.
+ (let ((o-match (make-overlay start end nil 'front-advance nil)))
+ (overlay-put o-match 'auto-overlay-match t)
+ (overlay-put o-match 'set-id set-id)
+ (overlay-put o-match 'definition-id definition-id)
+ (overlay-put o-match 'regexp-id regexp-id)
+ (overlay-put o-match 'delim-start
+ (set-marker (make-marker)
+ (if delim-start delim-start start)))
+ (overlay-put o-match 'delim-end
+ (set-marker (make-marker)
+ (if delim-end delim-end end)))
+ (set-marker-insertion-type (overlay-get o-match 'delim-start) t)
+ (set-marker-insertion-type (overlay-get o-match 'delim-end) nil)
+ (overlay-put o-match 'modification-hooks '(auto-o-schedule-suicide))
+ (overlay-put o-match 'insert-in-front-hooks '(auto-o-schedule-suicide))
+ (overlay-put o-match 'insert-behind-hooks '(auto-o-schedule-suicide))
+ ;; return the new match overlay
+ o-match))
+
+
+
+
+(defun auto-o-match-overlay (overlay start &optional end
+ no-props no-parse protect-match)
+ "Match start and end of OVERLAY with START and END match overlays.
+If START or END are numbers or markers, move that edge to the
+buffer location specified by the number or marker and make it
+unmatched. If START or END are non-nil but neither of the above,
+make that edge unmatched. If START or END are null, don't change
+that edge. However, if END is null, and START is an 'end overlay,
+match end of OVERLAY rather than start.
+
+If NO-PARSE is non-nil, block re-parsing due to exclusive overlay
+changes. If NO-PROPS is non-nil, block updating of overlay's
+properties. If PROTECT-MATCH is non-nil, don't modify any match
+overlays associated with OVERLAY (i.e. don't modify their 'parent
+properties)."
+
+ (let ((old-start (overlay-start overlay))
+ (old-end (overlay-end overlay))
+ (old-o-start (overlay-get overlay 'start))
+ (old-o-end (overlay-get overlay 'end))
+ (old-exclusive (overlay-get overlay 'exclusive))
+ (old-priority (overlay-get overlay 'priority)))
+
+ ;; if END is null, we're not unmatching, and START is an end overlay,
+ ;; match end of overlay instead of start (Note: assumes we're matching an
+ ;; overlay class with 'start and 'end regexps)
+ (when (and (null end) (overlayp start) (eq (auto-o-edge start) 'end))
+ (setq end start)
+ (setq start nil))
+
+
+ ;; move overlay to new location
+ (move-overlay overlay
+ (cond
+ ((overlayp start) (overlay-get start 'delim-end))
+ ((number-or-marker-p start) start)
+ (start (point-min))
+ (t (overlay-start overlay)))
+ (cond
+ ((overlayp end) (overlay-get end 'delim-start))
+ ((number-or-marker-p end) end)
+ (end (point-max))
+ (t (overlay-end overlay))))
+
+ ;; if changing start match...
+ (when start
+ ;; sort out parent property of old start match
+ (when (and old-o-start (not (eq old-o-start end)) (null protect-match))
+ (overlay-put old-o-start 'parent nil))
+ ;; if unmatching start, set start property to nil
+ (if (not (overlayp start))
+ (overlay-put overlay 'start nil)
+ ;; if matching start, set start property to new start match
+ (overlay-put overlay 'start start)
+ (overlay-put start 'parent overlay)))
+
+ ;; if changing end match...
+ (when end
+ ;; sort out parent property of old end match
+ (when (and old-o-end (not (eq old-o-end start)) (null protect-match))
+ (overlay-put old-o-end 'parent nil))
+ ;; if unmatching end, set end property to nil
+ (if (not (overlayp end))
+ (overlay-put overlay 'end nil)
+ ;; if matching end, set end property to new end match
+ (overlay-put overlay 'end end)
+ (overlay-put end 'parent overlay)))
+
+
+ ;; unless it's blocked, update properties if new match takes precedence
+ ;; (Note: this sometimes sets the overlay's properties to the ones it
+ ;; already had, but it hardly seems worth checking for that)
+ (unless no-props
+ ;; when start was previously matched and is being changed, remove
+ ;; properties due to old start match
+ ;; Note: no need to check if properties were really set by start match,
+ ;; since if not they will be recreated below
+ (when (and start old-o-start)
+ (dolist (p (auto-o-props old-o-start))
+ (overlay-put overlay (car p) nil)))
+ ;; when end was previously matched and is being changed, remove
+ ;; properties due to old end match (see note above)
+ (when (and end old-o-end)
+ (dolist (p (auto-o-props old-o-end))
+ (overlay-put overlay (car p) nil)))
+ ;; sort out properties due to new matches
+ (let (props)
+ (cond
+ ;; if start has been unmatched, use properties of end match
+ ((not (auto-o-start-matched-p overlay))
+ (setq props (auto-o-props (overlay-get overlay 'end))))
+ ;; if end has been unmatched, use properties of start match
+ ((not (auto-o-end-matched-p overlay))
+ (setq props (auto-o-props (overlay-get overlay 'start))))
+ (t ;; otherwise, use properties of whichever match takes precedence
+ (let ((o-start (overlay-get overlay 'start))
+ (o-end (overlay-get overlay 'end)))
+ (if (<= (auto-o-rank o-start)
+ (auto-o-rank o-end))
+ (setq props (auto-o-props o-start))
+ (setq props (auto-o-props o-end))))))
+ ;; bundle properties inside a list if not already, then update them
+ (when (symbolp (car props)) (setq props (list props)))
+ (dolist (p props) (overlay-put overlay (car p) (cdr p)))))
+
+
+ ;; unless it's blocked or overlay is inactive, check if anything needs
+ ;; reparsing due to exclusive overlay changes
+ (unless (or no-parse (overlay-get overlay 'inactive))
+ (let ((set-id (overlay-get overlay 'set-id))
+ (start (overlay-start overlay))
+ (end (overlay-end overlay))
+ (exclusive (overlay-get overlay 'exclusive))
+ (priority (overlay-get overlay 'priority)))
+ (cond
+
+ ;; if overlay wasn't and still isn't exclusive, do nothing
+ ((and (null exclusive) (null old-exclusive)))
+
+ ;; if overlay has become exclusive, delete lower priority overlays
+ ;; within it
+ ((and (null old-exclusive) exclusive)
+ (auto-o-update-exclusive set-id start end nil priority))
+
+ ;; if overlay was exclusive but no longer is, re-parse region it
+ ;; used to cover
+ ((and old-exclusive (null exclusive))
+ (auto-o-update-exclusive set-id old-start old-end old-priority nil))
+
+ ;; if overlay was and is exclusive, and has been moved to a
+ ;; completely different location re-parse old location and delete
+ ;; lower priority overlays within new location
+ ((or (< end old-start) (> start old-start))
+ (auto-o-update-exclusive set-id start end old-priority nil)
+ (auto-o-update-exclusive set-id start end nil priority))
+
+ ;; if overlay was and is exclusive, and overlaps its old location...
+ (t
+ ;; if priority has changed, re-parse/delete in overlap region
+ (when (/= old-priority priority)
+ (auto-o-update-exclusive set-id
+ (max start old-start) (min end old-end)
+ old-priority priority))
+ (cond
+ ;; if overlay was exclusive and start has shrunk, re-parse
+ ;; uncovered region
+ ((and (> start old-start) old-exclusive)
+ (auto-o-update-exclusive set-id old-start start old-priority nil))
+ ;; if overlay is exclusive and has grown, delete lower priority
+ ;; overlays in newly covered region
+ ((and (< start old-start) exclusive)
+ (auto-o-update-exclusive set-id start old-start nil priority)))
+ (cond
+ ;; if overlay was exclusive and end has shrunk, re-parse
+ ((and (< end old-end) old-exclusive)
+ (auto-o-update-exclusive set-id end old-end old-priority nil))
+ ;; if overlay is exclusive and has grown, delete lower priority
+ ((and (> end old-end) exclusive)
+ (auto-o-update-exclusive set-id old-end end nil priority))))
+ )))
+ ))
+
+
+
+
+(defun auto-o-delete-overlay (overlay &optional no-parse protect-match)
+ "Delete OVERLAY from buffer.
+
+If PROTECT-MATCH is non-nil, don't modify any match overlays
+associated with OVERLAY (i.e. leave their 'parent properties
+alone). If NO-PARSE is non-nil, block re-parsing due to exclusive
+overlay changes."
+
+ (let ((start (overlay-start overlay))
+ (end (overlay-end overlay))
+ o-match)
+ ;; delete overlay from buffer and `auto-overlay-list'
+ (delete-overlay overlay)
+ (unless (setq o-match (overlay-get overlay 'start))
+ (setq o-match (overlay-get overlay 'end)))
+;; (auto-o-delete-from-overlay-list overlay)
+
+ ;; unless blocked, if overlay's exclusive flag was set, re-parse region it
+ ;; covered
+ (when (and (null no-parse) (overlay-get overlay 'exclusive))
+ (auto-o-update-exclusive (overlay-get overlay 'set-id) start end
+ (overlay-get overlay 'priority) nil))
+
+ ;; Note: it's vital that the match overlays' parent properties are only
+ ;; set to nil *after* `auto-update-exclusive' is run: if the overlay
+ ;; overlapped one of its match overlays, the newly parentless match
+ ;; overlay would be re-parsed by `auto-update-exclusive', which would
+ ;; re-create the parent overlay that's just been deleted!
+
+ ;; unmatch match overlays
+ (unless protect-match
+ (when (setq o-match (overlay-get overlay 'start))
+ (overlay-put o-match 'parent nil))
+ (when (setq o-match (overlay-get overlay 'end))
+ (overlay-put o-match 'parent nil)))
+ ))
+
+
+
+
+(defun auto-o-matched-p (beg end set-id definition-id &optional regexp-id)
+ ;; Determine if characters between BEG end END are already matched by a
+ ;; match overlay corresponding to DEFINITION-ID (and optionally REGEXP-ID)
+ ;; of regexp set SET-ID.
+ (let (o-match)
+ (catch 'match
+ (mapc (lambda (o)
+ (when (and (overlay-get o 'auto-overlay-match)
+ (eq (overlay-get o 'set-id) set-id)
+ (eq (overlay-get o 'definition-id) definition-id)
+ (eq (overlay-get o 'regexp-id) regexp-id)
+ (= (overlay-start o) beg)
+ (= (overlay-end o) end))
+ (setq o-match o)
+ (throw 'match t)))
+ (overlays-in beg end)))
+ o-match))
+
+
+
+
+(defun auto-o-within-exclusive-p (match &optional end priority)
+ ;; If MATCH is an overlay, determine if it is within a higher priority
+ ;; exclusive overlay. If MATCH is a number or marker, determine whether
+ ;; region between MATCH and END is within an exclusive overlay with higher
+ ;; priority than PRIORITY.
+
+ (when (null end)
+ (setq end (overlay-get match 'delim-end))
+ (setq priority (overlay-get match 'priority))
+ (setq match (overlay-get match 'delim-start)))
+
+ ;; look for higher priority exclusive overlays
+ (auto-overlays-in
+ match end
+ (list '(identity auto-overlay)
+ '(identity exclusive)
+ (list (lambda (p q) (and p (or (null q) (> p q))))
+ 'priority priority)))
+)
+
+
+
+
+(defun auto-o-overlapping-match (beg end set-id definition-id regexp-id edge)
+ ;; Returns any match overlay corresponding to same SET-ID, DEFINITION-ID and
+ ;; EDGE but different REGEXP-ID whose delimiter overlaps region from BEG to
+ ;; END. (Only returns first one it finds; which is returned if more than one
+ ;; exists is undefined.)
+ (let (o-overlap)
+ (catch 'match
+ (mapc (lambda (o)
+ (when (and (overlay-get o 'auto-overlay-match)
+ (eq (overlay-get o 'set-id) set-id)
+ (eq (overlay-get o 'definition-id) definition-id)
+ (not (eq (overlay-get o 'regexp-id) regexp-id))
+ (eq (auto-o-edge o) edge)
+ ;; check delimiter (not just o) overlaps BEG to END
+ (< (overlay-get o 'delim-start) end)
+ (> (overlay-get o 'delim-end) beg))
+ (setq o-overlap o)
+ (throw 'match t)))
+ (overlays-in beg end)))
+ o-overlap))
+
+
+
+
+;;; ===============================================================
+;;; Compatibility Stuff
+
+(unless (fboundp 'line-number-at-pos)
+ (require 'auto-overlays-compat)
+ (defalias 'line-number-at-pos
+ 'auto-overlays-compat-line-number-at-pos))
+
+
+(unless (fboundp 'replace-regexp-in-string)
+ (require 'auto-overlays-compat)
+ (defalias 'replace-regexp-in-string
+ 'auto-overlays-compat-replace-regexp-in-string))
+
+;;; auto-overlays.el ends here