Download
(eval-when-compile (require 'cl))
(require 'bookmark)
(cond ((and (fboundp 'bookmark-name-from-record) (not (fboundp 'bookmark-name-from-full-record)))
(defalias 'bookmark-name-from-full-record 'bookmark-name-from-record))
((and (fboundp 'bookmark-name-from-full-record) (not (fboundp 'bookmark-name-from-record)))
(defalias 'bookmark-name-from-record 'bookmark-name-from-full-record)))
(defalias 'bmkp-bookmark-data-from-record 'bookmark-get-bookmark-record)
(defalias 'bmkp-bookmark-name-from-record 'bookmark-name-from-full-record)
(require 'pp+ nil t)
(defvar bmkp-light-left-fringe-bitmap)
(defvar bmkp-light-right-fringe-bitmap)
(defvar fringe-bitmaps)
(defface bmkp-light-autonamed
'((((background dark)) (:background "#00004AA652F1"))
(t (:background "misty rose")))
"*Face used to highlight an autonamed bookmark (except in the fringe)."
:group 'bookmark-plus :group 'faces)
(when (fboundp 'fringe-columns)
(defface bmkp-light-fringe-autonamed
'((((background dark)) (:background "#B19E6A64B19E"))
(t (:background "#691DC8A2691D")))
"*Face used to highlight an autonamed bookmark in the fringe."
:group 'bookmark-plus :group 'faces)
(defface bmkp-light-fringe-non-autonamed
'((((background dark)) (:background "#691DC8A2691D"))
(t (:foreground "Black" :background "Plum")))
"*Face used to highlight a non-autonamed bookmark in the fringe."
:group 'bookmark-plus :group 'faces))
(defface bmkp-light-mark '((t (:background "Plum")))
"*Face used to mark highlighted bookmarks in the bookmark list.
This face must be combinable with face `bmkp-t-mark'."
:group 'bookmark-plus :group 'faces)
(defface bmkp-light-non-autonamed
'((((background dark)) (:background "#B19E6A64B19E"))
(t (:background "DarkSeaGreen1")))
"*Face used to highlight a non-autonamed bookmark (except in the fringe)."
:group 'bookmark-plus :group 'faces)
(defcustom bmkp-auto-light-relocate-when-jump-flag t
"*Non-nil means highlight the relocated, instead of the recorded, position.
This has an effect only when the highlighting style for the bookmark
is `point'."
:type 'boolean :group 'bookmark-plus)
(defcustom bmkp-auto-light-when-jump nil
"*Which bookmarks to automatically highlight when jumped to.
NOTE: The values that specify highlighting in the current buffer
highlight bookmarks in the buffer that is current after jumping. If
the bookmark does not really have an associated buffer, for example a
bookmark with a handler such as `w32-browser' that just invokes a
separate, non-Emacs program, then the current buffer after jumping
will be the buffer before jumping."
:type '(choice
(const :tag "Autonamed bookmark" autonamed-bookmark)
(const :tag "Non-autonamed bookmark" non-autonamed-bookmark)
(const :tag "Any bookmark" any-bookmark)
(const :tag "Autonamed bookmarks in buffer" autonamed-in-buffer)
(const :tag "Non-autonamed bookmarks in buffer" non-autonamed-in-buffer)
(const :tag "All bookmarks in buffer" all-in-buffer)
(const :tag "None (no automatic highlighting)" nil))
:group 'bookmark-plus)
(defcustom bmkp-auto-light-when-set nil
"*Which bookmarks to automatically highlight when set."
:type '(choice
(const :tag "Autonamed bookmark" autonamed-bookmark)
(const :tag "Non-autonamed bookmark" non-autonamed-bookmark)
(const :tag "Any bookmark" any-bookmark)
(const :tag "Autonamed bookmarks in buffer" autonamed-in-buffer)
(const :tag "Non-autonamed bookmarks in buffer" non-autonamed-in-buffer)
(const :tag "All bookmarks in buffer" all-in-buffer)
(const :tag "None (no automatic highlighting)" nil))
:group 'bookmark-plus)
(defcustom bmkp-light-priorities '((bmkp-autonamed-overlays . 160)
(bmkp-non-autonamed-overlays . 150))
"*Priorities of bookmark highlighting overlay types.
As an idea, `ediff' uses 100+, `isearch' uses 1001."
:group 'bookmark-plus :type '(alist :key-type symbol :value-type integer))
(when (fboundp 'fringe-columns)
(defcustom bmkp-light-left-fringe-bitmap 'left-triangle
"*Symbol for the left fringe bitmap to use to highlight a bookmark.
This option is not used for Emacs versions before Emacs 22."
:type (cons 'choice (mapcar (lambda (bb) (list 'const bb)) fringe-bitmaps))
:group 'bookmark-plus)
(defcustom bmkp-light-right-fringe-bitmap 'right-triangle
"*Symbol for the right fringe bitmap to use to highlight a bookmark.
This option is not used for Emacs versions before Emacs 22."
:type (cons 'choice (mapcar (lambda (bb) (list 'const bb)) fringe-bitmaps))
:group 'bookmark-plus))
(defvar bmkp-light-styles-alist (append '(("Line Beginning" . bol)
("Position" . point)
("Line" . line)
("None" . none))
(and (fboundp 'fringe-columns)
'(("Left Fringe" . lfringe)
("Right Fringe" . rfringe)
("Left Fringe + Line" . line+lfringe)
("Right Fringe + Line" . line+rfringe))))
"Alist of highlighting styles. Key: string description. Value: symbol.")
(defun bmkp-light-style-choices ()
"Return custom `:type' used for bookmark highlighting style choices."
(cons 'choice
(mapcar (lambda (xx) (list 'const :tag (car xx) (cdr xx))) bmkp-light-styles-alist)))
(defcustom bmkp-light-style-autonamed (if (not (fboundp 'fringe-columns))
'line
'line+lfringe)
"*Default highlight style for autonamed bookmarks."
:group 'bookmark-plus :type (bmkp-light-style-choices))
(defcustom bmkp-light-style-non-autonamed (if (not (fboundp 'fringe-columns))
'line
'line+rfringe)
"*Default highlight style for non-autonamed bookmarks."
:group 'bookmark-plus :type (bmkp-light-style-choices))
(defcustom bmkp-light-threshold 100000
"*Maximum number of bookmarks to highlight."
:type 'integer :group 'bookmark-plus)
(defvar bmkp-autonamed-overlays nil
"Overlays used to highlight autonamed bookmarks.")
(defvar bmkp-non-autonamed-overlays nil
"Overlays used to highlight non-autonamed bookmarks.")
(defun bmkp-bmenu-show-only-lighted ()
"Display a list of highlighted bookmarks (only)."
(interactive)
(bmkp-bmenu-barf-if-not-in-menu-list)
(setq bmkp-bmenu-filter-function 'bmkp-lighted-alist-only
bmkp-bmenu-title "Highlighted Bookmarks")
(let ((bookmark-alist (funcall bmkp-bmenu-filter-function)))
(setq bmkp-latest-bookmark-alist bookmark-alist)
(bookmark-bmenu-list 'filteredp))
(when (interactive-p)
(bmkp-msg-about-sort-order (bmkp-current-sort-order) "Only highlighted bookmarks are shown")))
(defun bmkp-bmenu-light ()
"Highlight the location of this line's bookmark."
(interactive)
(bmkp-bmenu-barf-if-not-in-menu-list)
(bmkp-light-bookmark (bookmark-bmenu-bookmark) nil nil 'MSG))
(defun bmkp-bmenu-light-marked (&optional parg msgp)
"Highlight the marked bookmarks."
(interactive (list 'MSG))
(bmkp-bmenu-barf-if-not-in-menu-list)
(when msgp (message "Highlighting marked bookmarks..."))
(let ((marked (bmkp-marked-bookmarks-only)))
(unless marked (error "No marked bookmarks"))
(dolist (bmk marked) (bmkp-light-bookmark bmk)))
(when msgp (message "Highlighting marked bookmarks...done")))
(defun bmkp-bmenu-unlight ()
"Unhighlight the location of this line's bookmark."
(interactive)
(bmkp-bmenu-barf-if-not-in-menu-list)
(bmkp-unlight-bookmark (bookmark-bmenu-bookmark) 'NOERROR))
(defun bmkp-bmenu-unlight-marked (&optional parg msgp)
"Unhighlight the marked bookmarks."
(interactive (list 'MSG))
(bmkp-bmenu-barf-if-not-in-menu-list)
(when msgp (message "Unhighlighting marked bookmarks..."))
(let ((marked (bmkp-marked-bookmarks-only)))
(unless marked (error "No marked bookmarks"))
(dolist (bmk marked) (bmkp-unlight-bookmark bmk t)))
(when msgp (message "Unhighlighting marked bookmarks...done")))
(defun bmkp-bmenu-set-lighting (style face when &optional msgp)
"Set the `lighting' property for this line's bookmark.
You are prompted for the highlight style, face, and condition (when)."
(interactive
(let* ((bmk (bookmark-bmenu-bookmark))
(bmk-style (bmkp-lighting-style bmk))
(bmk-face (bmkp-lighting-face bmk))
(bmk-when (bmkp-lighting-when bmk)))
(append (bmkp-read-set-lighting-args
(and bmk-style (format "%s" (car (rassq bmk-style bmkp-light-styles-alist))))
(and bmk-face (format "%S" bmk-face))
(and bmk-when (format "%S" bmk-when)))
'(MSG))))
(bmkp-bmenu-barf-if-not-in-menu-list)
(bmkp-set-lighting-for-bookmark (bookmark-bmenu-bookmark) style face when 'MSG))
(defun bmkp-bmenu-set-lighting-for-marked (style face when &optional msgp)
"Set the `lighting' property for the marked bookmarks.
You are prompted for the highlight style, face, and condition (when)."
(interactive (append (bmkp-read-set-lighting-args) '(MSG)))
(bmkp-bmenu-barf-if-not-in-menu-list)
(when msgp (message "Setting highlighting..."))
(let ((marked (bmkp-marked-bookmarks-only))
(curr-bmk (bookmark-bmenu-bookmark)))
(unless marked (error "No marked bookmarks"))
(dolist (bmk marked)
(if (or face style when)
(bookmark-prop-set bmk 'lighting
`(,@(and face (not (eq face 'auto)) `(:face ,face))
,@(and style (not (eq style 'none)) `(:style ,style))
,@(and when (not (eq when 'auto)) `(:when ,when))))
(bookmark-prop-set bmk 'lighting nil)))
(when (get-buffer-create "*Bookmark List*") (bmkp-refresh-menu-list curr-bmk)))
(when msgp (message "Setting highlighting...done")))
(defun bmkp-bookmarks-lighted-at-point (&optional position fullp msgp)
"Return a list of the bookmarks highlighted at point.
Include only those in the current bookmark list (`bookmark-alist').
With no prefix arg, return the bookmark names.
With a prefix arg, return the full bookmark data.
Interactively, display the info.
Non-interactively:
Use the bookmarks at optional arg POSITION (default: point).
Optional arg FULLP means return full bookmark data.
Optional arg MSGP means display the info."
(interactive (list (point) current-prefix-arg 'MSG))
(unless position (setq position (point)))
(let ((bmks ())
bmk)
(dolist (ov (overlays-at position))
(when (setq bmk (overlay-get ov 'bookmark))
(when (setq bmk (bmkp-get-bookmark-in-alist bmk 'NOERROR))
(push (if fullp bmk (bmkp-bookmark-name-from-record bmk)) bmks))))
(if (not fullp)
(when msgp (message "%s" bmks))
(setq bmks (mapcar #'bookmark-get-bookmark bmks))
(when msgp (pp-eval-expression 'bmks)))
bmks))
(defun bmkp-lighted-jump (bookmark-name &optional use-region-p)
"Jump to a highlighted bookmark.
This is a specialization of `bookmark-jump' - see that, in particular
for info about using a prefix argument."
(interactive
(let ((alist (bmkp-lighted-alist-only)))
(unless alist (error "No highlighted bookmarks"))
(list (bookmark-completing-read "Jump to highlighted bookmark" nil alist) current-prefix-arg)))
(bmkp-jump-1 bookmark-name 'switch-to-buffer use-region-p))
(defun bmkp-lighted-jump-other-window (bookmark-name &optional use-region-p)
"Jump to a highlighted bookmark in another window.
See `bmkp-lighted-jump'."
(interactive
(let ((alist (bmkp-lighted-alist-only)))
(unless alist (error "No highlighted bookmarks"))
(list (bookmark-completing-read "Jump to highlighted bookmark in another window" nil alist)
current-prefix-arg)))
(bmkp-jump-1 bookmark-name 'bmkp-select-buffer-other-window use-region-p))
(defun bmkp-unlight-bookmark (bookmark &optional noerrorp msgp)
"Unhighlight BOOKMARK.
BOOKMARK is a bookmark name or a bookmark record."
(interactive
(let ((lighted-bmks (bmkp-lighted-alist-only)))
(unless lighted-bmks (error "No highlighted bookmarks"))
(list (bookmark-completing-read "UNhighlight bookmark" (bmkp-default-lighted) lighted-bmks)
nil
'MSG)))
(let* ((bmk (bookmark-get-bookmark bookmark 'NOERROR))
(bmk-name (bmkp-bookmark-name-from-record bmk))
(autonamedp (and bmk (bmkp-autonamed-bookmark-p bmk))))
(when bmk
(unless (or noerrorp (bmkp-lighted-p bmk-name))
(error "Bookmark `%s' is not highlighted" bmk-name))
(dolist (ov (if autonamedp bmkp-autonamed-overlays bmkp-non-autonamed-overlays))
(when (eq bmk (overlay-get ov 'bookmark)) (delete-overlay ov))))
(when msgp (message "UNhighlighted bookmark `%s'" bmk-name))))
(defun bmkp-unlight-bookmark-here (&optional noerrorp msgp)
"Unhighlight a bookmark at point or the same line (in that order)."
(interactive (list nil 'MSG))
(let ((bmk (or (bmkp-a-bookmark-lighted-at-pos) (bmkp-a-bookmark-lighted-on-this-line))))
(unless bmk (error "No highlighted bookmark on this line"))
(bmkp-unlight-bookmark bmk noerrorp msgp)))
(defun bmkp-unlight-bookmark-this-buffer (bookmark &optional noerrorp msgp)
"Unhighlight a BOOKMARK in this buffer.
BOOKMARK is a bookmark name or a bookmark record.
With a prefix arg, choose from all bookmarks, not just those in this
buffer."
(interactive
(let ((lighted-bmks (if current-prefix-arg
(bmkp-lighted-alist-only)
(bmkp-this-buffer-lighted-alist-only)))
(msg-suffix (if current-prefix-arg "" " in this buffer")))
(unless lighted-bmks (error "No highlighted bookmarks%s" msg-suffix))
(list (bookmark-completing-read (format "UNhighlight bookmark%s in this buffer" msg-suffix)
(bmkp-default-lighted)
lighted-bmks)
nil
'MSG)))
(bmkp-unlight-bookmark bookmark noerrorp msgp))
(defun bmkp-unlight-bookmarks (&optional overlays-symbols this-buffer-p msgp)
"Unhighlight bookmarks.
A prefix argument determines which bookmarks to unhighlight:
none - Current buffer, all bookmarks.
>= 0 - Current buffer, autonamed bookmarks only.
< 0 - Current buffer, non-autonamed bookmarks only.
C-u - All buffers (all bookmarks)."
(interactive (list (cond ((or (not current-prefix-arg) (consp current-prefix-arg))
'(bmkp-autonamed-overlays bmkp-non-autonamed-overlays))
((natnump current-prefix-arg) '(bmkp-autonamed-overlays))
(current-prefix-arg '(bmkp-non-autonamed-overlays)))
(or (not current-prefix-arg) (atom current-prefix-arg))
'MSG))
(unless overlays-symbols
(setq overlays-symbols '(bmkp-autonamed-overlays bmkp-non-autonamed-overlays)))
(let ((count 0)
(count-auto 0)
(count-non-auto 0)
(this-buf (current-buffer)))
(dolist (ov-symb overlays-symbols)
(dolist (ov (symbol-value ov-symb))
(let ((ov-buf (overlay-buffer ov)))
(when (and ov-buf (or (not this-buffer-p) (eq ov-buf this-buf)))
(when (eq 'bmkp-autonamed-overlays ov-symb)
(setq count-auto (1+ count-auto)
count (1+ count)))
(when (eq 'bmkp-non-autonamed-overlays ov-symb)
(setq count-non-auto (1+ count-non-auto)
count (1+ count)))
(delete-overlay ov)))))
(when msgp (message "UNhighlighted %d bookmarks %s: %d autonamed, %d other"
count (if this-buffer-p "in this buffer" "(all buffers)")
count-auto count-non-auto))))
(defun bmkp-unlight-autonamed-this-buffer (&optional everywherep)
"Unhighlight autonamed bookmarks.
No prefix arg: unhighlight them only in the current buffer.
Prefix arg, unhighlight them everywhere."
(interactive "P")
(bmkp-unlight-bookmarks '(bmkp-autonamed-overlays) (not everywherep)))
(defun bmkp-unlight-non-autonamed-this-buffer (&optional everywherep)
"Unhighlight non-autonamed bookmarks.
No prefix arg: unhighlight them only in the current buffer.
Prefix arg, unhighlight them everywhere."
(interactive "P")
(bmkp-unlight-bookmarks '(bmkp-non-autonamed-overlays) (not everywherep)))
(defun bmkp-unlight-this-buffer ()
"Unhighlight all bookmarks in the current buffer."
(interactive)
(bmkp-unlight-bookmarks))
(defun bmkp-set-lighting-for-bookmark (bookmark-name style face when &optional msgp light-now-p)
"Set the `lighting' property for bookmark BOOKMARK-NAME.
You are prompted for the bookmark, highlight style, face, and condition.
With a prefix argument, do not highlight now.
Non-interactively:
STYLE, FACE, and WHEN are as for a bookmark's `lighting' property
entries, or nil if no such entry.
Non-nil MSGP means display a highlighting progress message.
Non-nil LIGHT-NOW-P means apply the highlighting now."
(interactive
(let* ((bmk (bookmark-completing-read "Highlight bookmark"
(or (bmkp-default-lighted) (bmkp-default-bookmark-name))))
(bmk-style (bmkp-lighting-style bmk))
(bmk-face (bmkp-lighting-face bmk))
(bmk-when (bmkp-lighting-when bmk)))
(append (list bmk)
(bmkp-read-set-lighting-args
(and bmk-style (format "%s" (car (rassq bmk-style bmkp-light-styles-alist))))
(and bmk-face (format "%S" bmk-face))
(and bmk-when (format "%S" bmk-when)))
(list 'MSGP (not current-prefix-arg)))))
(when msgp (message "Setting highlighting..."))
(if (or face style when)
(bookmark-prop-set bookmark-name
'lighting `(,@(and face (not (eq face 'auto)) `(:face ,face))
,@(and style (not (eq style 'none)) `(:style ,style))
,@(and when (not (eq when 'auto)) `(:when ,when))))
(bookmark-prop-set bookmark-name 'lighting nil))
(when (get-buffer-create "*Bookmark List*") (bmkp-refresh-menu-list bookmark-name))
(when msgp (message "Setting highlighting...done"))
(when light-now-p (bmkp-light-bookmark bookmark-name nil nil msgp)))
(defun bmkp-set-lighting-for-buffer (buffer style face when &optional msgp light-now-p)
"Set the `lighting' property for each of the bookmarks for BUFFER.
You are prompted for the highlight style, face, and condition (when).
With a prefix argument, do not highlight now.
Non-interactively:
STYLE, FACE, and WHEN are as for a bookmark's `lighting' property
entries, or nil if no such entry.
Non-nil MSGP means display a highlighting progress message.
Non-nil LIGHT-NOW-P means apply the highlighting now."
(interactive (append (list (bmkp-completing-read-buffer-name))
(bmkp-read-set-lighting-args)
(list 'MSGP (not current-prefix-arg))))
(bmkp-set-lighting-for-bookmarks
(let ((bmkp-last-specific-buffer buffer)) (bmkp-last-specific-buffer-alist-only))
style face when msgp light-now-p))
(defun bmkp-set-lighting-for-this-buffer (style face when &optional msgp light-now-p)
"Set the `lighting' property for each of the bookmarks for this buffer.
You are prompted for the highlight style, face, and condition (when).
With a prefix argument, do not highlight now.
Non-interactively:
STYLE, FACE, and WHEN are as for a bookmark's `lighting' property
entries, or nil if no such entry.
Non-nil MSGP means display a highlighting progress message.
Non-nil LIGHT-NOW-P means apply the highlighting now."
(interactive (append (bmkp-read-set-lighting-args) (list 'MSGP (not current-prefix-arg))))
(bmkp-set-lighting-for-bookmarks (bmkp-this-buffer-alist-only) style face when msgp light-now-p))
(defun bmkp-set-lighting-for-bookmarks (alist style face when &optional msgp light-now-p)
"Set the `lighting' property for each of the bookmarks in ALIST.
STYLE, FACE, and WHEN are as for a bookmark's `lighting' property
entries, or nil if no such entry.
Non-nil MSGP means display a highlighting progress message.
Non-nil LIGHT-NOW-P means apply the highlighting now."
(when msgp (message "Setting highlighting..."))
(dolist (bmk alist) (bmkp-set-lighting-for-bookmark bmk style face when))
(when msgp (message "Setting highlighting...done"))
(when light-now-p (bmkp-light-bookmarks alist nil msgp)))
(defun bmkp-light-bookmark (bookmark &optional style face msgp pointp)
"Highlight BOOKMARK.
With a prefix arg you are prompted for the style and/or face to use:
Plain prefix arg (`C-u'): prompt for both style and face.
Numeric non-negative arg: prompt for face.
Numeric negative arg: prompt for style.
Non-interactively:
BOOKMARK is a bookmark name or a bookmark record, or it is ignored.
STYLE and FACE override the defaults.
POINT-P non-nil means highlight point rather than the recorded
bookmark position."
(interactive
(let* ((bmk (bookmark-completing-read "Highlight bookmark" (bmkp-default-bookmark-name)))
(sty (and current-prefix-arg (or (consp current-prefix-arg)
(<= (prefix-numeric-value current-prefix-arg) 0))
(cdr (assoc (let ((completion-ignore-case t))
(completing-read
"Style: " bmkp-light-styles-alist nil t nil nil
(and (bmkp-lighting-style bmk)
(format "%s" (car (rassq (bmkp-lighting-style bmk)
bmkp-light-styles-alist))))))
bmkp-light-styles-alist))))
(fac (and current-prefix-arg (or (consp current-prefix-arg)
(natnump (prefix-numeric-value current-prefix-arg)))
(not (member sty '(lfringe rfringe none)))
(condition-case nil
(read-face-name "Face: " (format "%S" (bmkp-lighting-face bmk)))
(wrong-number-of-arguments (read-face-name "Face: "))))))
(list bmk sty fac 'MSG)))
(let* ((bmkp-use-region nil)
(bmk (bookmark-get-bookmark bookmark (not msgp)))
(bmk-name (bmkp-bookmark-name-from-record bmk))
(pos (and bmk (bookmark-get-position bmk)))
(buf (and bmk (bmkp-get-buffer-name bmk)))
(autonamedp (and bmk (bmkp-autonamed-bookmark-p bmk)))
(styl (or style (and bmk (bmkp-light-style bmk))))
(fac (or face (and bmk
(not (member styl '(lfringe rfringe none)))
(bmkp-light-face bmk))))
(passes-when-p (and bmk (or face
style
(bmkp-light-when bmk))))
(nb-lit (bmkp-number-lighted))
bmk-ov)
(catch 'bmkp-light-bookmark
(when bmk
(cond ((setq bmk-ov (bmkp-overlay-of-bookmark bmk))
(if (not (or style face))
(when msgp
(error "Already highlighted - use prefix arg to change"))
(when style (bmkp-make/move-overlay-of-style style pos autonamedp bmk-ov))
(when (and face (not (memq styl '(lfringe rfringe none))))
(overlay-put bmk-ov 'face face)))
(when msgp (message "%sighlighted bookmark `%s'" (if bmk-ov "H" "UNh") bmk-name)))
(passes-when-p
(save-excursion
(with-current-buffer (or (and buf (get-buffer buf))
(current-buffer))
(when (and pointp bmkp-auto-light-relocate-when-jump-flag)
(setq pos (point)))
(when (and pos (< pos (point-max)))
(let ((ov (bmkp-make/move-overlay-of-style styl pos autonamedp)))
(when ov
(let ((ovs (if autonamedp
'bmkp-autonamed-overlays
'bmkp-non-autonamed-overlays)))
(push ov (symbol-value ovs)))
(when (and (not (bmkp-lighted-p bmk))
(> (setq nb-lit (1+ nb-lit)) bmkp-light-threshold))
(setq nb-lit (1- nb-lit))
(throw 'bmkp-light-bookmark bmk))
(overlay-put ov 'priority
(or (cdr (assoc (if autonamedp
'bmkp-autonamed-overlays
'bmkp-non-autonamed-overlays)
bmkp-light-priorities))
(apply #'min (mapcar #'cdr bmkp-light-priorities))))
(unless (memq styl '(lfringe rfringe none)) (overlay-put ov 'face fac))
(overlay-put ov 'evaporate t)
(overlay-put ov 'category 'bookmark-plus)
(overlay-put ov 'bookmark bmk))
(when msgp
(message "%sighlighted bookmark `%s'" (if ov "H" "UNh") bmk-name)))))))
(t
(when msgp (message "Bookmark's condition canceled highlighting"))))))))
(defun bmkp-light-bookmark-this-buffer (bookmark &optional style face msgp)
"Highlight a BOOKMARK in the current buffer.
With a prefix arg you are prompted for the style and/or face to use:
Plain prefix arg (`C-u'): prompt for both style and face.
Numeric non-negative arg: prompt for face.
Numeric negative arg: prompt for style.
See `bmkp-light-boookmark' for argument descriptions."
(interactive
(let* ((bmk (bookmark-completing-read "Highlight bookmark" nil (bmkp-this-buffer-alist-only)))
(sty (and current-prefix-arg (or (consp current-prefix-arg)
(<= (prefix-numeric-value current-prefix-arg) 0))
(cdr (assoc (let ((completion-ignore-case t))
(completing-read
"Style: " bmkp-light-styles-alist nil t nil nil
(and (bmkp-lighting-style bmk)
(format "%s" (car (rassq (bmkp-lighting-style bmk)
bmkp-light-styles-alist))))))
bmkp-light-styles-alist))))
(fac (and current-prefix-arg (or (consp current-prefix-arg)
(natnump (prefix-numeric-value current-prefix-arg)))
(not (member sty '(lfringe rfringe none)))
(condition-case nil
(read-face-name "Face: " (format "%S" (bmkp-lighting-face bmk)))
(wrong-number-of-arguments (read-face-name "Face: "))))))
(list bmk sty fac 'MSG)))
(bmkp-light-bookmark bookmark style face msgp))
(defun bmkp-light-bookmarks (&optional alist overlays-symbols msgp)
"Highlight bookmarks.
A prefix argument determines which bookmarks to highlight:
none - Current buffer, all bookmarks.
= 0 - Current buffer, highlighted bookmarks only (rehighlight).
> 0 - Current buffer, autonamed bookmarks only.
< 0 - Current buffer, non-autonamed bookmarks only.
C-u - All buffers (all bookmarks) - after confirmation.
C-u C-u - Navlist (all bookmarks).
Non-interactively, ALIST is the alist of bookmarks to highlight.
It must be provided: if nil then do not highlight any bookmarks."
(interactive
(list (cond ((not current-prefix-arg) (bmkp-this-buffer-alist-only))
((consp current-prefix-arg) (if (> (prefix-numeric-value current-prefix-arg) 4)
bmkp-nav-alist
(unless
(y-or-n-p
"Confirm highlighting bookmarks in ALL buffers ")
(error "Canceled highlighting"))
(bmkp-specific-buffers-alist-only
(mapcar #'buffer-name (buffer-list)))))
((> current-prefix-arg 0) (bmkp-autonamed-this-buffer-alist-only))
((< current-prefix-arg 0) (bmkp-remove-if #'bmkp-autonamed-bookmark-p
(bmkp-this-buffer-alist-only)))
((= current-prefix-arg 0) (bmkp-this-buffer-lighted-alist-only)))
(cond ((or (not current-prefix-arg) (consp current-prefix-arg))
'(bmkp-autonamed-overlays bmkp-non-autonamed-overlays))
((natnump current-prefix-arg) '(bmkp-autonamed-overlays))
(current-prefix-arg '(bmkp-non-autonamed-overlays)))
'MSG))
(unless overlays-symbols
(setq overlays-symbols '(bmkp-autonamed-overlays bmkp-non-autonamed-overlays)))
(let ((bmkp-use-region nil)
(total 0)
(nb-auto 0)
(nb-non-auto 0)
(new-auto 0)
(new-non-auto 0)
(nb-lit (bmkp-number-lighted))
bmk bmk-name autonamedp face style pos buf bmk-ov passes-when-p)
(catch 'bmkp-light-bookmarks
(dolist (bookmark alist)
(setq bmk (bookmark-get-bookmark bookmark 'NOERROR)
bmk-name (and bmk (bmkp-bookmark-name-from-record bmk))
autonamedp (and bmk (bmkp-autonamed-bookmark-p bmk-name))
face (and bmk (bmkp-light-face bmk))
style (and bmk (bmkp-light-style bmk))
bmk-ov (bmkp-overlay-of-bookmark bmk)
passes-when-p (and bmk (or bmk-ov
(bmkp-light-when bmk))))
(when (and bmk passes-when-p)
(setq pos (bookmark-get-position bmk)
buf (bmkp-get-buffer-name bmk))
(save-excursion
(with-current-buffer (or (and buf (get-buffer buf))
(current-buffer))
(when (and pos (< pos (point-max)))
(dolist (ov-symb overlays-symbols)
(when (or (and (eq 'bmkp-autonamed-overlays ov-symb) autonamedp)
(and (eq 'bmkp-non-autonamed-overlays ov-symb) (not autonamedp)))
(let ((ov (bmkp-make/move-overlay-of-style style pos autonamedp bmk-ov)))
(when ov
(add-to-list ov-symb ov)
(when (eq 'bmkp-autonamed-overlays ov-symb)
(unless bmk-ov (setq new-auto (1+ new-auto)))
(setq nb-auto (1+ nb-auto)))
(when (eq 'bmkp-non-autonamed-overlays ov-symb)
(unless bmk-ov (setq new-non-auto (1+ new-non-auto)))
(setq nb-non-auto (1+ nb-non-auto)))
(when (and (not bmk-ov) (> (setq nb-lit (1+ nb-lit)) bmkp-light-threshold))
(setq nb-lit (1- nb-lit))
(throw 'bmkp-light-bookmarks bmk))
(setq total (1+ total))
(overlay-put ov 'priority
(or (cdr (assoc ov-symb bmkp-light-priorities))
(apply #'min (mapcar #'cdr bmkp-light-priorities))))
(unless (memq style '(lfringe rfringe none)) (overlay-put ov 'face face))
(overlay-put ov 'evaporate t)
(overlay-put ov 'category 'bookmark-plus)
(overlay-put ov 'bookmark bmk)))))))))))
(when msgp (message "%s New: %d auto + %d other, Total: %d auto + %d other = %d"
(if (consp current-prefix-arg)
(if (> (prefix-numeric-value current-prefix-arg) 4)
"[Navlist]"
"[All buffers]")
"[This buffer]")
new-auto new-non-auto nb-auto nb-non-auto total))))
(defun bmkp-light-navlist-bookmarks (&optional overlays-symbols msgp)
"Highlight bookmarks in the navigation list.
No prefix arg: all bookmarks.
Prefix arg >= 0: autonamed bookmarks only.
Prefix arg < 0: non-autonamed bookmarks only."
(interactive
(list (cond ((not current-prefix-arg) '(bmkp-autonamed-overlays bmkp-non-autonamed-overlays))
((natnump (prefix-numeric-value current-prefix-arg)) '(bmkp-autonamed-overlays))
(current-prefix-arg '(bmkp-non-autonamed-overlays)))
'MSG))
(bmkp-light-bookmarks bmkp-nav-alist overlays-symbols msgp))
(defun bmkp-light-this-buffer (&optional overlays-symbols msgp)
"Highlight bookmarks in the current buffer.
No prefix arg: all bookmarks.
Prefix arg >= 0: autonamed bookmarks only.
Prefix arg < 0: non-autonamed bookmarks only."
(interactive
(list (cond ((not current-prefix-arg) '(bmkp-autonamed-overlays bmkp-non-autonamed-overlays))
((natnump (prefix-numeric-value current-prefix-arg)) '(bmkp-autonamed-overlays))
(current-prefix-arg '(bmkp-non-autonamed-overlays)))
'MSG))
(bmkp-light-bookmarks (bmkp-this-buffer-alist-only) overlays-symbols msgp))
(defun bmkp-light-bookmarks-in-region (start end &optional overlays-symbols msgp)
"Highlight bookmarks in the region.
No prefix arg: all bookmarks.
Prefix arg >= 0: autonamed bookmarks only.
Prefix arg < 0: non-autonamed bookmarks only."
(interactive
(list (region-beginning)
(region-end)
(cond ((not current-prefix-arg) '(bmkp-autonamed-overlays bmkp-non-autonamed-overlays))
((natnump (prefix-numeric-value current-prefix-arg)) '(bmkp-autonamed-overlays))
(current-prefix-arg '(bmkp-non-autonamed-overlays)))
'MSG))
(bmkp-light-bookmarks (bmkp-remove-if-not (lambda (bmk) (let ((pos (bookmark-get-position bmk)))
(and (>= pos start) (<= pos end))))
(bmkp-this-buffer-alist-only))
overlays-symbols msgp))
(defun bmkp-light-autonamed-this-buffer (&optional msgp)
"Highlight all autonamed bookmarks."
(interactive (list 'MSG))
(bmkp-light-bookmarks (bmkp-autonamed-this-buffer-alist-only) '(bmkp-autonamed-overlays) msgp))
(defun bmkp-light-non-autonamed-this-buffer (&optional msgp)
"Highlight all non-autonamed bookmarks."
(interactive (list 'MSG))
(bmkp-light-bookmarks (bmkp-remove-if #'bmkp-autonamed-bookmark-p (bmkp-this-buffer-alist-only))
'(bmkp-non-autonamed-overlays) msgp))
(defun bmkp-cycle-lighted-this-buffer (increment &optional other-window startoverp)
"Cycle through highlighted bookmarks in this buffer by INCREMENT.
Positive INCREMENT cycles forward. Negative INCREMENT cycles backward.
Interactively, the prefix arg determines INCREMENT:
Plain `C-u': 1
otherwise: the numeric prefix arg value
To change the sort order, you can filter the `*Bookmark List*' to show
only highlighted bookmarks for this buffer, sort the bookmarks there,
and use `\\[bmkp-choose-navlist-from-bookmark-list]', choosing `CURRENT *Bookmark List*' as the
navigation list.
Then you can cycle the bookmarks using `bookmark-cycle'
\(`\\[bmkp-next-bookmark-repeat]' etc.), instead of `bookmark-cycle-lighted-this-buffer'.
In Lisp code:
Non-nil OTHER-WINDOW means jump to the bookmark in another window.
Non-nil STARTOVERP means reset `bmkp-current-nav-bookmark' to the
first bookmark in the navlist."
(interactive (let ((startovr (consp current-prefix-arg)))
(list (if startovr 1 (prefix-numeric-value current-prefix-arg)) nil startovr)))
(bookmark-maybe-load-default-file)
(let ((bmkp-sort-comparer bmkp-this-file/buffer-cycle-sort-comparer))
(setq bmkp-nav-alist (bmkp-sort-omit (bmkp-this-buffer-lighted-alist-only))))
(unless bmkp-nav-alist (error "No lighted bookmarks for cycling"))
(unless (and bmkp-current-nav-bookmark
(not startoverp)
(bookmark-get-bookmark bmkp-current-nav-bookmark 'NOERROR)
(bmkp-this-buffer-p bmkp-current-nav-bookmark))
(setq bmkp-current-nav-bookmark (car bmkp-nav-alist)))
(if (bmkp-cycle-1 increment other-window startoverp)
(unless (or (bmkp-sequence-bookmark-p bmkp-current-nav-bookmark)
(bmkp-function-bookmark-p bmkp-current-nav-bookmark))
(message "Position: %9d, Bookmark: `%s'" (point) (bmkp-bookmark-name-from-record
bmkp-current-nav-bookmark)))
(message "Invalid bookmark: `%s'" (bmkp-bookmark-name-from-record bmkp-current-nav-bookmark))))
(defun bmkp-cycle-lighted-this-buffer-other-window (increment &optional startoverp)
"Same as `bmkp-cycle-lighted-this-buffer' but uses another window."
(interactive (let ((startovr (consp current-prefix-arg)))
(list (if startovr 1 (prefix-numeric-value current-prefix-arg)) startovr)))
(bmkp-cycle-lighted-this-buffer increment 'OTHER-WINDOW startoverp))
(defun bmkp-next-lighted-this-buffer (n &optional startoverp)
"Jump to the Nth-next highlighted bookmark in the current buffer.
N defaults to 1, meaning the next one.
Plain `C-u' means start over at the first one.
See also `bmkp-cycle-lighted-this-buffer'."
(interactive (let ((startovr (consp current-prefix-arg)))
(list (if startovr 1 (prefix-numeric-value current-prefix-arg)) startovr)))
(bmkp-cycle-lighted-this-buffer n nil startoverp))
(defun bmkp-previous-lighted-this-buffer (n &optional startoverp)
"Jump to the Nth-previous highlighted bookmark in the current buffer.
See `bmkp-next-lighted-this-buffer'."
(interactive (let ((startovr (consp current-prefix-arg)))
(list (if startovr 1 (prefix-numeric-value current-prefix-arg)) startovr)))
(bmkp-cycle-lighted-this-buffer (- n) nil startoverp))
(defun bmkp-next-lighted-this-buffer-repeat (arg)
"Jump to the Nth next highlighted bookmark in the current buffer.
This is a repeatable version of `bmkp-next-bookmark-this-buffer'.
N defaults to 1, meaning the next one.
Plain `C-u' means start over at the first one (and no repeat)."
(interactive "P")
(require 'repeat)
(bmkp-repeat-command 'bmkp-next-lighted-this-buffer))
(defun bmkp-previous-lighted-this-buffer-repeat (arg)
"Jump to the Nth previous highlighted bookmark in the current buffer.
See `bmkp-next-lighted-this-buffer-repeat'."
(interactive "P")
(require 'repeat)
(bmkp-repeat-command 'bmkp-previous-lighted-this-buffer))
(defun bmkp-light-face (bookmark)
"Return the face to use to highlight BOOKMARK.
BOOKMARK is a bookmark name or a bookmark record.
Returns:
nil if BOOKMARK is not a valid bookmark
the `:face' specified by BOOKMARK's `lighting' property, if any
`bmkp-light-autonamed' if BOOKMARK is an autonamed bookmark
or `bmkp-light-non-autonamed' otherwise."
(setq bookmark (bookmark-get-bookmark bookmark 'NOERROR))
(or (bmkp-lighting-face bookmark)
(and bookmark (if (bmkp-string-match-p (format bmkp-autoname-format ".*")
(bmkp-bookmark-name-from-record bookmark))
'bmkp-light-autonamed
'bmkp-light-non-autonamed))))
(defun bmkp-light-style (bookmark)
"Return the style to use to highlight BOOKMARK.
BOOKMARK is a bookmark name or a bookmark record.
Returns:
nil if BOOKMARK is not a valid bookmark
the `:style' specified by BOOKMARK's `lighting' property, if any
the value of `bmkp-light-style-autonamed' if autonamed
or the value of `bmkp-light-style-non-autonamed' otherwise."
(setq bookmark (bookmark-get-bookmark bookmark 'NOERROR))
(or (bmkp-lighting-style bookmark)
(and bookmark (if (bmkp-string-match-p (format bmkp-autoname-format ".*")
(bmkp-bookmark-name-from-record bookmark))
bmkp-light-style-autonamed
bmkp-light-style-non-autonamed))))
(defun bmkp-light-when (bookmark)
"Return non-nil if BOOKMARK should be highlighted.
BOOKMARK's `:when' condition is used to determine this.
BOOKMARK is a bookmark name or a bookmark record."
(setq bookmark (bookmark-get-bookmark bookmark 'NOERROR))
(let ((this-bookmark bookmark)
(this-bookmark-name (bmkp-bookmark-name-from-record bookmark))
(when-sexp (bmkp-lighting-when bookmark)))
(not (eq :no-light (eval when-sexp)))))
(defun bmkp-lighting-face (bookmark)
"`:face' specified by BOOKMARK's `lighting', or nil if no `:face' entry.
BOOKMARK is a bookmark name or a bookmark record.
The `:face' entry is the face (a symbol) used to highlight BOOKMARK.
Alternatively, it can be `auto' or nil, which both mean the same as
having no `:face' entry: do not override automatic face choice."
(bmkp-lighting-attribute bookmark :face))
(defun bmkp-lighting-style (bookmark)
"`:style' specified by BOOKMARK's `lighting', or nil if no `:style' entry.
BOOKMARK is a bookmark name or a bookmark record.
The `:style' entry is the style used to highlight BOOKMARK.
It is a value acceptable for `bmkp-light-style-non-autonamed'.
Alternatively, it can be `auto' or nil, which both mean the same as
having no `:style' entry: do not override automatic style choice."
(bmkp-lighting-attribute bookmark :style))
(defun bmkp-lighting-when (bookmark)
"`:when' specified by BOOKMARK's `lighting', or nil if no `:when' entry.
BOOKMARK is a bookmark name or a bookmark record.
The `:when' entry is a sexp that is eval'd when you try to highlight
BOOKMARK. If the result is the symbol `:no-light', then do not
highlight. Otherwise, highlight. (Note that highlighting happens if
the value is nil or there is no `:when' entry.)"
(bmkp-lighting-attribute bookmark :when))
(defun bmkp-lighting-attribute (bookmark attribute)
"ATTRIBUTE specified by BOOKMARK's `lighting', or nil if no such attribute.
BOOKMARK is a bookmark name or a bookmark record.
ATTRIBUTE is `:style' or `:face'."
(setq bookmark (bookmark-get-bookmark bookmark 'NOERROR))
(let* ((lighting (and bookmark (bmkp-get-lighting bookmark)))
(attr (and (consp lighting) (plist-get lighting attribute))))
(when (and (eq 'auto attr) (not (eq :when attribute)))
(setq attr nil))
attr))
(defun bmkp-get-lighting (bookmark)
"Return the `lighting' property list for BOOKMARK.
This is the cdr of the `lighting' entry (i.e. with `lighting' removed).
BOOKMARK is a bookmark name or a bookmark record."
(bookmark-prop-get bookmark 'lighting))
(defun bmkp-bookmark-overlay-p (overlay)
"Return non-nil if OVERLAY is a bookmark overlay.
The non-nil value returned is in fact the full bookmark."
(and (overlayp overlay) (overlay-get overlay 'bookmark)))
(defun bmkp-default-lighted ()
"Return a highlighted bookmark at point or on this line, or nil if none.
For Emacs 23+, if there is a highlighted bookmark at point, return a
list of all such."
(or (if (> emacs-major-version 22)
(bmkp-bookmarks-lighted-at-point)
(bmkp-a-bookmark-lighted-at-pos))
(bmkp-a-bookmark-lighted-on-this-line)))
(defun bmkp-a-bookmark-lighted-on-this-line (&optional fullp msgp)
"Return a bookmark highlighted on the current line or nil if none.
The search for a highlighted bookmark moves left to bol from point,
then right to eol from point.
Return the bookmark name or, if FULLP non-nil, the full bookmark data."
(let ((pos (point))
(bol (1+ (line-beginning-position)))
(eol (1- (line-end-position)))
bmk)
(catch 'bmkp-a-bookmark-lighted-on-this-line
(while (>= pos bol)
(when (setq bmk (bmkp-a-bookmark-lighted-at-pos pos))
(throw 'bmkp-a-bookmark-lighted-on-this-line bmk))
(setq pos (1- pos)))
(while (<= pos eol)
(when (setq bmk (bmkp-a-bookmark-lighted-at-pos pos))
(throw 'bmkp-a-bookmark-lighted-on-this-line bmk))
(setq pos (1+ pos)))
nil)
(when (and bmk fullp) (setq bmk (bookmark-get-bookmark bmk)))
bmk))
(defun bmkp-a-bookmark-lighted-at-pos (&optional position fullp)
"Return a bookmark (in current bookmark list) highlighted at POSITION.
Return nil if there is none such.
POSITION defaults to point.
Return the bookmark name or, if FULLP non-nil, the full bookmark data."
(unless position (setq position (point)))
(let (bmk)
(catch 'bmkp-a-bookmark-lighted-at-pos
(dolist (ov (overlays-at position))
(when (setq bmk (overlay-get ov 'bookmark))
(throw 'bmkp-a-bookmark-lighted-at-pos bmk)))
nil)
(let ((b-in-list (bmkp-get-bookmark-in-alist bmk 'NOERROR)))
(and b-in-list
(if fullp b-in-list (bmkp-bookmark-name-from-record bmk))))))
(defun bmkp-read-set-lighting-args (&optional default-style default-face default-when)
"Read args STYLE, FACE, and WHEN for commands that set `lighting' prop.
Optional args are the default values (strings) for reading new values."
(let* ((icicle-unpropertize-completion-result-flag t)
(style (cdr (assoc (let ((completion-ignore-case t))
(completing-read "Style: " bmkp-light-styles-alist
nil t nil nil default-style))
bmkp-light-styles-alist)))
(face (and (not (member style '(lfringe rfringe none)))
(y-or-n-p "Change face? ")
(condition-case nil
(read-face-name "Face: " default-face)
(wrong-number-of-arguments (read-face-name "Face: ")))))
(when-cands `(("auto" . nil)
("conditionally (read sexp)")
("never" . :no-light)))
(when (completing-read "When: " when-cands nil t nil nil
(if default-when "conditionally (read sexp)" "auto")))
(evald (if (bmkp-string-match-p "^con" when)
(read-from-minibuffer "Highlight when (sexp): " nil
(if (boundp 'pp-read-expression-map)
pp-read-expression-map
read-expression-map)
t 'read-expression-history default-when)
(cdr (assoc when when-cands)))))
(list style face evald)))
(defun bmkp-lighted-alist-only ()
"`bookmark-alist', with only highlighted bookmarks.
A new list is returned (no side effects)."
(bookmark-maybe-load-default-file)
(bmkp-remove-if-not (lambda (bmk) (bmkp-lighted-p bmk)) bookmark-alist))
(defun bmkp-this-buffer-lighted-alist-only ()
"`bookmark-alist', with only highlighted bookmarks for the current buffer.
A new list is returned (no side effects)."
(bookmark-maybe-load-default-file)
(bmkp-remove-if-not (lambda (bmk) (and (bmkp-this-buffer-p bmk) (bmkp-lighted-p bmk)))
bookmark-alist))
(defun bmkp-number-lighted (&optional overlays-symbols)
"Number of bookmarks highlighted."
(unless overlays-symbols
(setq overlays-symbols '(bmkp-autonamed-overlays bmkp-non-autonamed-overlays)))
(let ((count 0))
(dolist (ov-symb overlays-symbols)
(dolist (ov (symbol-value ov-symb)) (when (overlay-buffer ov) (setq count (1+ count)))))
count))
(defalias 'bmkp-lighted-p 'bmkp-overlay-of-bookmark)
(defun bmkp-overlay-of-bookmark (bookmark &optional overlays)
"Return the overlay for BOOKMARK in OVERLAYS, or nil if none.
BOOKMARK is a bookmark name or a bookmark record.
Optional arg OVERLAYS is the list of overlays to check.
If nil, check overlays for both autonamed and non-autonamed bookmarks."
(setq bookmark (bookmark-get-bookmark bookmark 'NOERROR))
(and bookmark
(catch 'bmkp-overlay-of-bookmark
(dolist (ov (if overlays
(apply #'append (mapcar #'symbol-value overlays))
(append bmkp-autonamed-overlays bmkp-non-autonamed-overlays)))
(when (and (overlay-buffer ov) (eq bookmark (overlay-get ov 'bookmark)))
(throw 'bmkp-overlay-of-bookmark ov)))
nil)))
(defun bmkp-make/move-overlay-of-style (style pos autonamedp &optional overlay)
"Return a bookmark overlay of STYLE at bookmark position POS.
AUTONAMEDP non-nil means the bookmark is autonamed.
If OVERLAY is non-nil it is the overlay to use - change to STYLE.
Otherwise, create a new overlay.
If STYLE is `none' then:
If OVERLAY is non-nil, delete it.
Return nil."
(let ((ov overlay))
(when (and (< emacs-major-version 22) (not (rassq style bmkp-light-styles-alist)))
(message "Fringe styles not supported before Emacs 22 - changing to `line' style")
(setq style 'line))
(case style
(line (if (not ov)
(setq ov (save-excursion
(make-overlay
(progn (goto-char pos) (line-beginning-position 1))
(progn (goto-char pos) (line-beginning-position 2))
nil
'FRONT-ADVANCE)))
(overlay-put ov 'before-string nil)
(save-excursion
(move-overlay ov
(progn (goto-char pos) (line-beginning-position 1))
(progn (goto-char pos) (line-beginning-position 2))))))
(lfringe (setq ov (bmkp-make/move-fringe 'left pos autonamedp ov)))
(rfringe (setq ov (bmkp-make/move-fringe 'right pos autonamedp ov)))
(line+lfringe (setq ov (bmkp-make/move-fringe 'left pos autonamedp ov 'LINEP)))
(line+rfringe (setq ov (bmkp-make/move-fringe 'right pos autonamedp ov 'LINEP)))
(bol (if (not ov)
(setq ov (save-excursion (goto-char pos)
(make-overlay (line-beginning-position)
(1+ (line-beginning-position))
nil
'FRONT-ADVANCE)))
(overlay-put ov 'before-string nil)
(save-excursion (goto-char pos)
(move-overlay ov (line-beginning-position)
(1+ (line-beginning-position))))))
(point (if (not ov)
(setq ov (make-overlay pos (1+ pos) nil 'FRONT-ADVANCE))
(overlay-put ov 'before-string nil)
(move-overlay ov pos (1+ pos))))
(none (when ov (delete-overlay ov)) (setq ov nil)))
ov))
(defun bmkp-make/move-fringe (side pos autonamedp &optional overlay linep)
"Return an overlay that uses the fringe.
If SIDE is `right' then use the right fringe, otherwise left.
POS is the overlay position.
AUTONAMEDP: non-nil means use face `bmkp-light-fringe-autonamed'.
nil means use face `bmkp-light-fringe-non-autonamed'.
If OVERLAY is non-nil it is the overlay to use.
Otherwise, create a new overlay.
Non-nil LINEP means also highlight the line containing POS."
(unless (> emacs-major-version 21) (error "Fringe styles not supported before Emacs 22"))
(let ((ov overlay))
(if ov
(save-excursion (move-overlay overlay (progn (goto-char pos)
(goto-char (line-beginning-position)))
(1+ (point))))
(setq ov (save-excursion (make-overlay (progn (goto-char pos)
(goto-char (line-beginning-position)))
(1+ (point))
nil
'FRONT-ADVANCE))))
(overlay-put ov 'before-string (bmkp-fringe-string side autonamedp))
(if linep
(move-overlay ov (save-excursion (goto-char pos) (line-beginning-position 1))
(save-excursion (goto-char pos) (line-beginning-position 2)))
(overlay-put ov 'face nil))
ov))
(defun bmkp-fringe-string (side autonamedp)
"Return a fringe string for a bookmark overlay.
If SIDE is `right' then use the right fringe, otherwise left.
AUTONAMEDP: non-nil means use face `bmkp-light-fringe-autonamed'.
nil means use face `bmkp-light-fringe-non-autonamed'."
(unless (> emacs-major-version 21) (error "Fringe styles not supported before Emacs 22"))
(let ((fringe-string (copy-sequence (if autonamedp "*AUTO*" "*NONAUTO*"))))
(put-text-property 0 (length fringe-string)
'display (if (eq side 'right)
(list 'right-fringe
bmkp-light-right-fringe-bitmap
(if autonamedp
'bmkp-light-fringe-autonamed
'bmkp-light-fringe-non-autonamed))
(list 'left-fringe
bmkp-light-left-fringe-bitmap
(if autonamedp
'bmkp-light-fringe-autonamed
'bmkp-light-fringe-non-autonamed)))
fringe-string)
fringe-string))
(provide 'bookmark+-lit)