1 ;;; bookmark+-lit.el --- Bookmark highlighting for Bookmark+.
3 ;; Filename: bookmark+-lit.el
4 ;; Description: Bookmark highlighting for Bookmark+.
6 ;; Maintainer: Drew Adams
7 ;; Copyright (C) 2010-2111, Drew Adams, all rights reserved.
8 ;; Created: Wed Jun 23 07:49:32 2010 (-0700)
9 ;; Last-Updated: Tue Aug 9 10:27:52 2011 (-0700)
12 ;; URL: http://www.emacswiki.org/cgi-bin/wiki/bookmark+-lit.el
13 ;; Keywords: bookmarks, highlighting, bookmark+
14 ;; Compatibility: GNU Emacs: 20.x, 21.x, 22.x, 23.x
16 ;; Features that might be required by this library:
18 ;; `bookmark', `pp', `pp+'.
20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
24 ;; Bookmark highlighting for Bookmark+ (library `bookmark+.el').
26 ;; The Bookmark+ libraries are:
28 ;; `bookmark+.el' - main code library
29 ;; `bookmark+-mac.el' - Lisp macros
30 ;; `bookmark+-lit.el' - code for highlighting bookmarks (this file)
31 ;; `bookmark+-bmu.el' - code for the `*Bookmark List*'
32 ;; `bookmark+-1.el' - other required code (non-bmenu)
33 ;; `bookmark+-key.el' - key and menu bindings
35 ;; `bookmark+-doc.el' - documentation (comment-only file)
36 ;; `bookmark+-chg.el' - change log (comment-only file)
38 ;; This library (`bookmark+-lit.el') is a Bookmark+ option. If you
39 ;; want to use it then load it before loading `bookmark+.el', so
40 ;; that its commands can be bound to keys and menu items.
42 ;; The documentation (in `bookmark+-doc.el') includes how to
43 ;; byte-compile and install Bookmark+. The documentation is also
44 ;; available in these ways:
46 ;; 1. From the bookmark list (`C-x r l'):
47 ;; Use `?' to show the current bookmark-list status and general
48 ;; help, then click link `Doc in Commentary' or link `Doc on the
51 ;; 2. From the Emacs-Wiki Web site:
52 ;; http://www.emacswiki.org/cgi-bin/wiki/BookmarkPlus.
54 ;; 3. From the Bookmark+ group customization buffer:
55 ;; `M-x customize-group bookmark-plus', then click link
58 ;; (The commentary links in #1 and #3 work only if you have library
59 ;; `bookmark+-doc.el' in your `load-path'.)
66 ;; If you have library `linkd.el' and Emacs 22 or later, load
67 ;; `linkd.el' and turn on `linkd-mode' now. It lets you easily
68 ;; navigate around the sections of this doc. Linkd mode will
69 ;; highlight this Index, as well as the cross-references and section
70 ;; headings throughout this file. You can get `linkd.el' here:
71 ;; http://dto.freeshell.org/notebook/Linkd.html.
73 ;; (@> "Things Defined Here")
74 ;; (@> "Faces (Customizable)")
75 ;; (@> "User Options (Customizable)")
76 ;; (@> "Internal Variables")
78 ;; (@> "Menu-List (`*-bmenu-*') Commands")
79 ;; (@> "General Highlight Commands")
80 ;; (@> "Other Functions")
82 ;;(@* "Things Defined Here")
84 ;; Things Defined Here
85 ;; -------------------
87 ;; Commands defined here:
90 ;; `bmkp-bmenu-light', `bmkp-bmenu-light-marked',
91 ;; `bmkp-bmenu-set-lighting', `bmkp-bmenu-set-lighting-for-marked',
92 ;; `bmkp-bmenu-show-only-lighted', `bmkp-bmenu-unlight',
93 ;; `bmkp-bmenu-unlight-marked', `bmkp-bookmarks-lighted-at-point',
94 ;; `bmkp-cycle-lighted-this-buffer',
95 ;; `bmkp-cycle-lighted-this-buffer-other-window',
96 ;; `bmkp-light-autonamed-this-buffer', `bmkp-light-bookmark',
97 ;; `bmkp-light-bookmark-this-buffer', `bmkp-light-bookmarks',
98 ;; `bmkp-light-bookmarks-in-region',
99 ;; `bmkp-light-navlist-bookmarks',
100 ;; `bmkp-light-non-autonamed-this-buffer',
101 ;; `bmkp-light-this-buffer', `bmkp-lighted-jump',
102 ;; `bmkp-lighted-jump-other-window',
103 ;; `bmkp-next-lighted-this-buffer',
104 ;; `bmkp-next-lighted-this-buffer-repeat',
105 ;; `bmkp-previous-lighted-this-buffer',
106 ;; `bmkp-previous-lighted-this-buffer-repeat',
107 ;; `bmkp-set-lighting-for-bookmark',
108 ;; `bmkp-set-lighting-for-buffer',
109 ;; `bmkp-set-lighting-for-this-buffer',
110 ;; `bmkp-unlight-autonamed-this-buffer', `bmkp-unlight-bookmark',
111 ;; `bmkp-unlight-bookmark-here',
112 ;; `bmkp-unlight-bookmark-this-buffer', `bmkp-unlight-bookmarks',
113 ;; `bmkp-unlight-non-autonamed-this-buffer',
114 ;; `bmkp-unlight-this-buffer'.
116 ;; User options defined here:
118 ;; `bmkp-auto-light-relocate-when-jump-flag',
119 ;; `bmkp-auto-light-when-jump', `bmkp-auto-light-when-set',
120 ;; `bmkp-light-left-fringe-bitmap' (Emacs 22+),
121 ;; `bmkp-light-priorities', `bmkp-light-right-fringe-bitmap' (Emacs
122 ;; 22+), `bmkp-light-style-autonamed',
123 ;; `bmkp-light-style-non-autonamed', `bmkp-light-threshold'.
125 ;; Faces defined here:
127 ;; `bmkp-light-autonamed', `bmkp-light-fringe-autonamed' (Emacs
128 ;; 22+), `bmkp-light-fringe-non-autonamed' (Emacs 22+),
129 ;; `bmkp-light-mark', `bmkp-light-non-autonamed'.
131 ;; Non-interactive functions defined here:
133 ;; `bmkp-a-bookmark-lighted-at-pos',
134 ;; `bmkp-a-bookmark-lighted-on-this-line',
135 ;; `bmkp-bookmark-overlay-p', `bmkp-default-lighted',
136 ;; `bmkp-fringe-string' (Emacs 22+), `bmkp-get-lighting',
137 ;; `bmkp-lighted-p', `bmkp-light-face', `bmkp-light-style',
138 ;; `bmkp-light-style-choices', `bmkp-light-when',
139 ;; `bmkp-lighted-alist-only', `bmkp-lighting-attribute',
140 ;; `bmkp-lighting-face', `bmkp-lighting-style',
141 ;; `bmkp-lighting-when', `bmkp-make/move-fringe' (Emacs 22+),
142 ;; `bmkp-make/move-overlay-of-style', `bmkp-number-lighted',
143 ;; `bmkp-overlay-of-bookmark', `bmkp-read-set-lighting-args',
144 ;; `bmkp-set-lighting-for-bookmarks',
145 ;; `bmkp-this-buffer-lighted-alist-only'.
147 ;; Internal variables defined here:
149 ;; `bmkp-autonamed-overlays', `bmkp-light-styles-alist',
150 ;; `bmkp-non-autonamed-overlays'.
152 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
154 ;; This program is free software; you can redistribute it and/or
155 ;; modify it under the terms of the GNU General Public License as
156 ;; published by the Free Software Foundation; either version 3, or
157 ;; (at your option) any later version.
159 ;; This program is distributed in the hope that it will be useful,
160 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
161 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
162 ;; General Public License for more details.
164 ;; You should have received a copy of the GNU General Public License
165 ;; along with this program; see the file COPYING. If not, write to
166 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
167 ;; Floor, Boston, MA 02110-1301, USA.
169 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
173 ;;;;;;;;;;;;;;;;;;;;;;;
175 (eval-when-compile (require 'cl)) ;; case
178 ;; bookmark-alist, bookmark-bmenu-bookmark, bookmark-completing-read,
179 ;; bookmark-get-bookmark, bookmark-get-position,
180 ;; bookmark-handle-bookmark, bookmark-maybe-load-default-file,
181 ;; bookmark-name-from-full-record, bookmark-name-from-record, bookmark-prop-get,
184 ;;; Fix incompatibility introduced by gratuitous Emacs name change.
185 (cond ((and (fboundp 'bookmark-name-from-record) (not (fboundp 'bookmark-name-from-full-record)))
186 (defalias 'bookmark-name-from-full-record 'bookmark-name-from-record))
187 ((and (fboundp 'bookmark-name-from-full-record) (not (fboundp 'bookmark-name-from-record)))
188 (defalias 'bookmark-name-from-record 'bookmark-name-from-full-record)))
190 ;; (eval-when-compile (require 'bookmark+-bmu))
191 ;; bmkp-bmenu-barf-if-not-in-menu-list, bmkp-bmenu-filter-function,
194 ;; (eval-when-compile (require 'bookmark+-1))
195 ;; bmkp-autonamed-bookmark-p, bmkp-autonamed-this-buffer-alist-only,
196 ;; bmkp-autoname-format, bmkp-current-nav-bookmark,
197 ;; bmkp-current-sort-order, bmkp-cycle-1, bmkp-default-bookmark-name,
198 ;; bmkp-function-bookmark-p, bmkp-get-buffer-name, bmkp-jump-1,
199 ;; bmkp-latest-bookmark-alist, bmkp-marked-bookmarks-only,
200 ;; bmkp-msg-about-sort-order, bmkp-nav-alist, bmkp-refresh-menu-list,
201 ;; bmkp-remove-if, bmkp-remove-if-not, bmkp-repeat-command,
202 ;; bmkp-sequence-bookmark-p, bmkp-sort-omit,
203 ;; bmkp-specific-buffers-alist-only, bmkp-this-buffer-alist-only,
204 ;; bmkp-this-buffer-cycle-sort-comparer, bmkp-this-buffer-p
206 (require 'pp+ nil t) ;; pp-read-expression-map
208 ;;;;;;;;;;;;;;;;;;;;;;;
210 ;; Quiet the byte-compiler
211 (defvar bmkp-light-left-fringe-bitmap) ; Defined in this file for Emacs 22+.
212 (defvar bmkp-light-right-fringe-bitmap) ; Defined in this file for Emacs 22+.
213 (defvar fringe-bitmaps) ; Built-in for Emacs 22+.
216 ;;(@* "Faces (Customizable)")
217 ;;; Faces (Customizable) ---------------------------------------------
219 (defface bmkp-light-autonamed
220 '((((background dark)) (:background "#00004AA652F1")) ; a dark cyan
221 (t (:background "misty rose"))) ; a light pink
222 "*Face used to highlight an autonamed bookmark (except in the fringe)."
223 :group 'bookmark-plus :group 'faces)
225 (when (fboundp 'fringe-columns)
226 (defface bmkp-light-fringe-autonamed
227 '((((background dark)) (:background "#B19E6A64B19E")) ; a dark magenta
228 (t (:background "#691DC8A2691D"))) ; a medium green
229 "*Face used to highlight an autonamed bookmark in the fringe."
230 :group 'bookmark-plus :group 'faces)
231 (defface bmkp-light-fringe-non-autonamed
232 '((((background dark)) (:background "#691DC8A2691D")) ; a medium green
233 (t (:foreground "Black" :background "Plum"))) ; a light magenta
234 "*Face used to highlight a non-autonamed bookmark in the fringe."
235 :group 'bookmark-plus :group 'faces))
237 (defface bmkp-light-mark '((t (:background "Plum")))
238 "*Face used to mark highlighted bookmarks in the bookmark list.
239 This face must be combinable with face `bmkp-t-mark'."
240 :group 'bookmark-plus :group 'faces)
242 (defface bmkp-light-non-autonamed
243 '((((background dark)) (:background "#B19E6A64B19E")) ; a dark magenta
244 (t (:background "DarkSeaGreen1"))) ; a light green
245 "*Face used to highlight a non-autonamed bookmark (except in the fringe)."
246 :group 'bookmark-plus :group 'faces)
248 ;;(@* "User Options (Customizable)")
249 ;;; User Options (Customizable) --------------------------------------
252 (defcustom bmkp-auto-light-relocate-when-jump-flag t
253 "*Non-nil means highlight the relocated, instead of the recorded, position.
254 This has an effect only when the highlighting style for the bookmark
256 :type 'boolean :group 'bookmark-plus)
259 (defcustom bmkp-auto-light-when-jump nil
260 "*Which bookmarks to automatically highlight when jumped to."
262 (const :tag "Autonamed bookmark" autonamed-bookmark)
263 (const :tag "Non-autonamed bookmark" non-autonamed-bookmark)
264 (const :tag "Any bookmark" any-bookmark)
265 (const :tag "Autonamed bookmarks in buffer" autonamed-in-buffer)
266 (const :tag "Non-autonamed bookmarks in buffer" non-autonamed-in-buffer)
267 (const :tag "All bookmarks in buffer" all-in-buffer)
268 (const :tag "None (no automatic highlighting)" nil))
269 :group 'bookmark-plus)
272 (defcustom bmkp-auto-light-when-set nil
273 "*Which bookmarks to automatically highlight when set."
275 (const :tag "Autonamed bookmark" autonamed-bookmark)
276 (const :tag "Non-autonamed bookmark" non-autonamed-bookmark)
277 (const :tag "Any bookmark" any-bookmark)
278 (const :tag "Autonamed bookmarks in buffer" autonamed-in-buffer)
279 (const :tag "Non-autonamed bookmarks in buffer" non-autonamed-in-buffer)
280 (const :tag "All bookmarks in buffer" all-in-buffer)
281 (const :tag "None (no automatic highlighting)" nil))
282 :group 'bookmark-plus)
285 (defcustom bmkp-light-priorities '((bmkp-autonamed-overlays . 160)
286 (bmkp-non-autonamed-overlays . 150))
287 "*Priorities of bookmark highlighting overlay types.
288 As an idea, `ediff' uses 100+, `isearch' uses 1001."
289 :group 'bookmark-plus :type '(alist :key-type symbol :value-type integer))
291 ;; Not used for Emacs 20-21.
292 (when (fboundp 'fringe-columns)
293 (defcustom bmkp-light-left-fringe-bitmap 'left-triangle
294 "*Symbol for the left fringe bitmap to use to highlight a bookmark.
295 This option is not used for Emacs versions before Emacs 22."
296 :type (cons 'choice (mapcar (lambda (bb) (list 'const bb)) fringe-bitmaps))
297 :group 'bookmark-plus)
299 ;; Not used for Emacs 20-21.
300 (defcustom bmkp-light-right-fringe-bitmap 'right-triangle
301 "*Symbol for the right fringe bitmap to use to highlight a bookmark.
302 This option is not used for Emacs versions before Emacs 22."
303 :type (cons 'choice (mapcar (lambda (bb) (list 'const bb)) fringe-bitmaps))
304 :group 'bookmark-plus))
306 ;; Must be before any options that use it.
307 (defvar bmkp-light-styles-alist (append '(("Line Beginning" . bol)
311 (and (fboundp 'fringe-columns)
312 '(("Left Fringe" . lfringe)
313 ("Right Fringe" . rfringe)
314 ("Left Fringe + Line" . line+lfringe)
315 ("Right Fringe + Line" . line+rfringe))))
316 "Alist of highlighting styles. Key: string description. Value: symbol.")
318 ;; Must be before options that use it.
319 (defun bmkp-light-style-choices ()
320 "Return custom `:type' used for bookmark highlighting style choices."
322 (mapcar (lambda (xx) (list 'const :tag (car xx) (cdr xx))) bmkp-light-styles-alist)))
325 (defcustom bmkp-light-style-autonamed (if (not (fboundp 'fringe-columns)) ; Emacs 20-21.
328 "*Default highlight style for autonamed bookmarks."
329 :group 'bookmark-plus :type (bmkp-light-style-choices))
332 (defcustom bmkp-light-style-non-autonamed (if (not (fboundp 'fringe-columns)) ; Emacs 20-21.
335 "*Default highlight style for non-autonamed bookmarks."
336 :group 'bookmark-plus :type (bmkp-light-style-choices))
339 (defcustom bmkp-light-threshold 100000
340 "*Maximum number of bookmarks to highlight."
341 :type 'integer :group 'bookmark-plus)
343 ;;(@* "Internal Variables")
344 ;;; Internal Variables -----------------------------------------------
346 (defvar bmkp-autonamed-overlays nil
347 "Overlays used to highlight autonamed bookmarks.")
349 (defvar bmkp-non-autonamed-overlays nil
350 "Overlays used to highlight non-autonamed bookmarks.")
353 ;;; Functions --------------------------------------------------------
356 ;;(@* "Menu-List (`*-bmenu-*') Commands")
357 ;; *** Menu-List (`*-bmenu-*') Commands ***
360 (defun bmkp-bmenu-show-only-lighted () ; `H S' in bookmark list
361 "Display a list of highlighted bookmarks (only)."
363 (bmkp-bmenu-barf-if-not-in-menu-list)
364 (setq bmkp-bmenu-filter-function 'bmkp-lighted-alist-only
365 bmkp-bmenu-title "Highlighted Bookmarks")
366 (let ((bookmark-alist (funcall bmkp-bmenu-filter-function)))
367 (setq bmkp-latest-bookmark-alist bookmark-alist)
368 (bookmark-bmenu-list 'filteredp))
369 (when (interactive-p)
370 (bmkp-msg-about-sort-order (bmkp-current-sort-order) "Only highlighted bookmarks are shown")))
373 (defun bmkp-bmenu-light () ; `H H' in bookmark list
374 "Highlight the location of this line's bookmark."
376 (bmkp-bmenu-barf-if-not-in-menu-list)
377 (bmkp-light-bookmark (bookmark-bmenu-bookmark) nil nil 'MSG))
380 (defun bmkp-bmenu-light-marked (&optional parg msgp) ; `H > H' in bookmark list
381 "Highlight the marked bookmarks."
382 (interactive (list 'MSG))
383 (bmkp-bmenu-barf-if-not-in-menu-list)
384 (when msgp (message "Highlighting marked bookmarks..."))
385 (let ((marked (bmkp-marked-bookmarks-only)))
386 (unless marked (error "No marked bookmarks"))
387 (dolist (bmk marked) (bmkp-light-bookmark bmk)))
388 (when msgp (message "Highlighting marked bookmarks...done")))
391 (defun bmkp-bmenu-unlight () ; `H U' in bookmark list
392 "Highlight the location of this line's bookmark."
394 (bmkp-bmenu-barf-if-not-in-menu-list)
395 (bmkp-unlight-bookmark (bookmark-bmenu-bookmark) 'NOERROR))
398 (defun bmkp-bmenu-unlight-marked (&optional parg msgp) ; `H > U' in bookmark list
399 "Unhighlight the marked bookmarks."
400 (interactive (list 'MSG))
401 (bmkp-bmenu-barf-if-not-in-menu-list)
402 (when msgp (message "Unhighlighting marked bookmarks..."))
403 (let ((marked (bmkp-marked-bookmarks-only)))
404 (unless marked (error "No marked bookmarks"))
405 (dolist (bmk marked) (bmkp-unlight-bookmark bmk t)))
406 (when msgp (message "Unhighlighting marked bookmarks...done")))
409 (defun bmkp-bmenu-set-lighting (style face when &optional msgp) ; `H +' in bookmark list
410 "Set the `lighting' property for this line's bookmark.
411 You are prompted for the highlight style, face, and condition (when)."
413 (let* ((bmk (bookmark-bmenu-bookmark))
414 (bmk-style (bmkp-lighting-style bmk))
415 (bmk-face (bmkp-lighting-face bmk))
416 (bmk-when (bmkp-lighting-when bmk)))
417 (append (bmkp-read-set-lighting-args
418 (and bmk-style (format "%s" (car (rassq bmk-style bmkp-light-styles-alist))))
419 (and bmk-face (format "%S" bmk-face))
420 (and bmk-when (format "%S" bmk-when)))
422 (bmkp-bmenu-barf-if-not-in-menu-list)
423 (bmkp-set-lighting-for-bookmark (bookmark-bmenu-bookmark) style face when 'MSG))
426 (defun bmkp-bmenu-set-lighting-for-marked (style face when &optional msgp) ; `H > +' in bookmark list
427 "Set the `lighting' property for the marked bookmarks.
428 You are prompted for the highlight style, face, and condition (when)."
429 (interactive (append (bmkp-read-set-lighting-args) '(MSG)))
430 (bmkp-bmenu-barf-if-not-in-menu-list)
431 (when msgp (message "Setting highlighting..."))
432 (let ((marked (bmkp-marked-bookmarks-only))
433 (curr-bmk (bookmark-bmenu-bookmark)))
434 (unless marked (error "No marked bookmarks"))
436 (if (or face style when)
437 (bookmark-prop-set bmk 'lighting
438 `(,@(and face (not (eq face 'auto)) `(:face ,face))
439 ,@(and style (not (eq style 'none)) `(:style ,style))
440 ,@(and when (not (eq when 'auto)) `(:when ,when))))
441 (bookmark-prop-set bmk 'lighting nil)))
442 (when (get-buffer-create "*Bookmark List*") (bmkp-refresh-menu-list curr-bmk)))
443 (when msgp (message "Setting highlighting...done")))
446 ;;(@* "General Highlight Commands")
447 ;; *** General Highlight Commands ***
450 (defun bmkp-bookmarks-lighted-at-point (&optional position fullp msgp) ; `C-x p ='
451 "Return a list of the bookmarks highlighted at point.
452 With no prefix arg, return the bookmark names.
453 With a prefix arg, return the full bookmark data.
454 Interactively, display the info.
455 Non-interactively, use the bookmarks at POSITION (default: point)."
456 (interactive (list (point) current-prefix-arg 'MSG))
457 (unless position (setq position (point)))
460 (dolist (ov (overlays-at position))
461 (when (setq bmk (overlay-get ov 'bookmark))
462 (push (if fullp (bookmark-get-bookmark bmk) bmk) bmks)))
464 (when msgp (message "%s" bmks))
465 (setq bmks (mapcar #'bookmark-get-bookmark bmks))
466 (when msgp (pp-eval-expression 'bmks)))
470 (defun bmkp-lighted-jump (bookmark-name &optional use-region-p) ; `C-x j h'
471 "Jump to a highlighted bookmark.
472 This is a specialization of `bookmark-jump' - see that, in particular
473 for info about using a prefix argument."
475 (let ((alist (bmkp-lighted-alist-only)))
476 (unless alist (error "No highlighted bookmarks"))
477 (list (bookmark-completing-read "Jump to highlighted bookmark" nil alist) current-prefix-arg)))
478 (bmkp-jump-1 bookmark-name 'switch-to-buffer use-region-p))
481 (defun bmkp-lighted-jump-other-window (bookmark-name &optional use-region-p) ; `C-x 4 j h'
482 "Jump to a highlighted bookmark in another window.
483 See `bmkp-lighted-jump'."
485 (let ((alist (bmkp-lighted-alist-only)))
486 (unless alist (error "No highlighted bookmarks"))
487 (list (bookmark-completing-read "Jump to highlighted bookmark in another window" nil alist)
488 current-prefix-arg)))
489 (bmkp-jump-1 bookmark-name 'bmkp-select-buffer-other-window use-region-p))
492 (defun bmkp-unlight-bookmark (bookmark &optional noerrorp msgp)
493 "Unhighlight BOOKMARK.
494 BOOKMARK is a bookmark name or a bookmark record."
496 (let ((lighted-bmks (bmkp-lighted-alist-only)))
497 (unless lighted-bmks (error "No highlighted bookmarks"))
498 (list (bookmark-completing-read "UNhighlight bookmark" (bmkp-default-lighted) lighted-bmks)
501 (let* ((bmk (bookmark-get-bookmark bookmark 'noerror))
502 (bmk-name (bookmark-name-from-full-record bmk))
503 (autonamedp (bmkp-autonamed-bookmark-p bmk)))
504 (when bmk ; Skip bad bookmark, but not already highlighted bookmark.
505 (unless (or noerrorp (bmkp-lighted-p bmk-name))
506 (error "Bookmark `%s' is not highlighted" bmk-name))
507 (dolist (ov (if autonamedp bmkp-autonamed-overlays bmkp-non-autonamed-overlays))
508 (when (equal bmk-name (overlay-get ov 'bookmark)) (delete-overlay ov))))
509 (when msgp (message "UNhighlighted bookmark `%s'" bmk-name))))
512 (defun bmkp-unlight-bookmark-here (&optional noerrorp msgp) ; `C-x p C-u'
513 "Unhighlight a bookmark at point or the same line (in that order)."
514 (interactive (list nil 'MSG))
515 (let ((bmk (or (bmkp-a-bookmark-lighted-at-pos) (bmkp-a-bookmark-lighted-on-this-line))))
516 (unless bmk (error "No highlighted bookmark on this line"))
517 (bmkp-unlight-bookmark bmk noerrorp msgp)))
520 (defun bmkp-unlight-bookmark-this-buffer (bookmark &optional noerrorp msgp) ; `C-x p u'
521 "Unhighlight a BOOKMARK in this buffer.
522 BOOKMARK is a bookmark name or a bookmark record.
523 With a prefix arg, choose from all bookmarks, not just those in this
526 (let ((lighted-bmks (if current-prefix-arg
527 (bmkp-lighted-alist-only)
528 (bmkp-this-buffer-lighted-alist-only)))
529 (msg-suffix (if current-prefix-arg "" " in this buffer")))
530 (unless lighted-bmks (error "No highlighted bookmarks%s" msg-suffix))
531 (list (bookmark-completing-read (format "UNhighlight bookmark%s in this buffer" msg-suffix)
532 (bmkp-default-lighted)
536 (bmkp-unlight-bookmark bookmark noerrorp msgp))
539 (defun bmkp-unlight-bookmarks (&optional overlays-symbols this-buffer-p msgp) ; `C-x p U'
540 "Unhighlight bookmarks.
541 A prefix argument determines which bookmarks to unhighlight:
542 none - Current buffer, all bookmarks.
543 >= 0 - Current buffer, autonamed bookmarks only.
544 < 0 - Current buffer, non-autonamed bookmarks only.
545 C-u - All buffers (all bookmarks)."
546 (interactive (list (cond ((or (not current-prefix-arg) (consp current-prefix-arg))
547 '(bmkp-autonamed-overlays bmkp-non-autonamed-overlays))
548 ((natnump current-prefix-arg) '(bmkp-autonamed-overlays))
549 (current-prefix-arg '(bmkp-non-autonamed-overlays)))
550 (or (not current-prefix-arg) (atom current-prefix-arg))
552 (unless overlays-symbols
553 (setq overlays-symbols '(bmkp-autonamed-overlays bmkp-non-autonamed-overlays)))
557 (this-buf (current-buffer)))
558 (dolist (ov-symb overlays-symbols)
559 (dolist (ov (symbol-value ov-symb))
560 (let ((ov-buf (overlay-buffer ov)))
561 (when (and ov-buf (or (not this-buffer-p) (eq ov-buf this-buf)))
562 (when (eq 'bmkp-autonamed-overlays ov-symb)
563 (setq count-auto (1+ count-auto)
565 (when (eq 'bmkp-non-autonamed-overlays ov-symb)
566 (setq count-non-auto (1+ count-non-auto)
568 (delete-overlay ov)))))
569 (when msgp (message "UNhighlighted %d bookmarks %s: %d autonamed, %d other"
570 count (if this-buffer-p "in this buffer" "(all buffers)")
571 count-auto count-non-auto))))
574 (defun bmkp-unlight-autonamed-this-buffer (&optional everywherep)
575 "Unhighlight autonamed bookmarks.
576 No prefix arg: unhighlight them only in the current buffer.
577 Prefix arg, unhighlight them everywhere."
579 (bmkp-unlight-bookmarks '(bmkp-autonamed-overlays) (not everywherep)))
582 (defun bmkp-unlight-non-autonamed-this-buffer (&optional everywherep)
583 "Unhighlight non-autonamed bookmarks.
584 No prefix arg: unhighlight them only in the current buffer.
585 Prefix arg, unhighlight them everywhere."
587 (bmkp-unlight-bookmarks '(bmkp-non-autonamed-overlays) (not everywherep)))
590 (defun bmkp-unlight-this-buffer ()
591 "Unhighlight all bookmarks in the current buffer."
593 (bmkp-unlight-bookmarks))
596 (defun bmkp-set-lighting-for-bookmark (bookmark-name style face when &optional msgp light-now-p)
597 "Set the `lighting' property for bookmark BOOKMARK-NAME.
598 You are prompted for the bookmark, highlight style, face, and condition.
599 With a prefix argument, do not highlight now.
602 STYLE, FACE, and WHEN are as for a bookmark's `lighting' property
603 entries, or nil if no such entry.
604 Non-nil MSGP means display a highlighting progress message.
605 Non-nil LIGHT-NOW-P means apply the highlighting now."
607 (let* ((bmk (bookmark-completing-read "Highlight bookmark"
608 (or (bmkp-default-lighted)
609 (bmkp-default-bookmark-name))))
610 (bmk-style (bmkp-lighting-style bmk))
611 (bmk-face (bmkp-lighting-face bmk))
612 (bmk-when (bmkp-lighting-when bmk)))
614 (bmkp-read-set-lighting-args
615 (and bmk-style (format "%s" (car (rassq bmk-style bmkp-light-styles-alist))))
616 (and bmk-face (format "%S" bmk-face))
617 (and bmk-when (format "%S" bmk-when)))
618 (list 'MSGP (not current-prefix-arg)))))
619 (when msgp (message "Setting highlighting..."))
620 (if (or face style when)
621 (bookmark-prop-set bookmark-name
622 'lighting `(,@(and face (not (eq face 'auto)) `(:face ,face))
623 ,@(and style (not (eq style 'none)) `(:style ,style))
624 ,@(and when (not (eq when 'auto)) `(:when ,when))))
625 (bookmark-prop-set bookmark-name 'lighting nil))
626 (when (get-buffer-create "*Bookmark List*") (bmkp-refresh-menu-list bookmark-name))
627 (when msgp (message "Setting highlighting...done"))
628 (when light-now-p (bmkp-light-bookmark bookmark-name nil nil msgp))) ; This msg is more informative.
631 (defun bmkp-set-lighting-for-buffer (buffer style face when &optional msgp light-now-p)
632 "Set the `lighting' property for each of the bookmarks for BUFFER.
633 You are prompted for the highlight style, face, and condition (when).
634 With a prefix argument, do not highlight now.
637 STYLE, FACE, and WHEN are as for a bookmark's `lighting' property
638 entries, or nil if no such entry.
639 Non-nil MSGP means display a highlighting progress message.
640 Non-nil LIGHT-NOW-P means apply the highlighting now."
641 (interactive (append (list (bmkp-completing-read-buffer-name))
642 (bmkp-read-set-lighting-args)
643 (list 'MSGP (not current-prefix-arg))))
644 (bmkp-set-lighting-for-bookmarks
645 (let ((bmkp-last-specific-buffer buffer)) (bmkp-last-specific-buffer-alist-only))
646 style face when msgp light-now-p))
649 (defun bmkp-set-lighting-for-this-buffer (style face when &optional msgp light-now-p)
650 "Set the `lighting' property for each of the bookmarks for this buffer.
651 You are prompted for the highlight style, face, and condition (when).
652 With a prefix argument, do not highlight now.
655 STYLE, FACE, and WHEN are as for a bookmark's `lighting' property
656 entries, or nil if no such entry.
657 Non-nil MSGP means display a highlighting progress message.
658 Non-nil LIGHT-NOW-P means apply the highlighting now."
659 (interactive (append (bmkp-read-set-lighting-args) (list 'MSGP (not current-prefix-arg))))
660 (bmkp-set-lighting-for-bookmarks (bmkp-this-buffer-alist-only) style face when msgp light-now-p))
662 (defun bmkp-set-lighting-for-bookmarks (alist style face when &optional msgp light-now-p)
663 "Set the `lighting' property for each of the bookmarks in ALIST.
664 STYLE, FACE, and WHEN are as for a bookmark's `lighting' property
665 entries, or nil if no such entry.
666 Non-nil MSGP means display a highlighting progress message.
667 Non-nil LIGHT-NOW-P means apply the highlighting now."
668 (when msgp (message "Setting highlighting..."))
669 (dolist (bmk alist) (bmkp-set-lighting-for-bookmark bmk style face when)) ; No MSGP arg here.
670 (when msgp (message "Setting highlighting...done"))
671 (when light-now-p (bmkp-light-bookmarks alist nil msgp))) ; Do separately so we get its message.
674 (defun bmkp-light-bookmark (bookmark &optional style face msgp pointp)
676 With a prefix arg you are prompted for the style and/or face to use:
677 Plain prefix arg (`C-u'): prompt for both style and face.
678 Numeric non-negative arg: prompt for face.
679 Numeric negative arg: prompt for style.
682 BOOKMARK is a bookmark name or a bookmark record.
683 STYLE and FACE override the defaults.
684 POINT-P non-nil means highlight point rather than the recorded
687 (let* ((bmk (bookmark-completing-read "Highlight bookmark" (bmkp-default-bookmark-name)))
688 (sty (and current-prefix-arg (or (consp current-prefix-arg)
689 (<= (prefix-numeric-value current-prefix-arg) 0))
690 (cdr (assoc (let ((completion-ignore-case t))
692 "Style: " bmkp-light-styles-alist nil t nil nil
693 (and (bmkp-lighting-style bmk)
694 (format "%s" (car (rassq (bmkp-lighting-style bmk)
695 bmkp-light-styles-alist))))))
696 bmkp-light-styles-alist))))
697 (fac (and current-prefix-arg (or (consp current-prefix-arg)
698 (natnump (prefix-numeric-value current-prefix-arg)))
699 (not (member sty '(lfringe rfringe none))) ; No face possible for these.
700 (condition-case nil ; Emacs 22+ accepts a default.
701 (read-face-name "Face: " (format "%S" (bmkp-lighting-face bmk)))
702 (wrong-number-of-arguments (read-face-name "Face: "))))))
703 (list bmk sty fac 'MSG)))
704 (let* ((bmkp-use-region nil) ; Inhibit region handling.
705 (bmk (bookmark-get-bookmark bookmark (not msgp))) ; Error if interactive.
706 (bmk-name (bookmark-name-from-full-record bmk))
707 (pos (bookmark-get-position bmk))
708 (buf (and bmk (bmkp-get-buffer-name bmk)))
709 (autonamedp (bmkp-autonamed-bookmark-p bmk))
710 (styl (or style (and bmk (bmkp-light-style bmk))))
711 (fac (or face (and bmk (not (member styl '(lfringe rfringe none)))
712 (bmkp-light-face bmk))))
713 (passes-when-p (and bmk (or face style ; Always highlight if changed face or style.
714 (bmkp-light-when bmk))))
715 (nb-lit (bmkp-number-lighted))
717 (catch 'bmkp-light-bookmark
718 (when bmk ; Just skip bad bookmark if not interactive.
719 (cond ((setq bmk-ov (bmkp-overlay-of-bookmark bmk))
720 (if (not (or style face))
721 (when msgp ; No-op batch.
722 (error "Already highlighted - use prefix arg to change"))
723 (when style (bmkp-make/move-overlay-of-style style pos autonamedp bmk-ov))
724 (when (and face (not (memq styl '(lfringe rfringe none))))
725 (overlay-put bmk-ov 'face face)))
726 (when msgp (message "%sighlighted bookmark `%s'" (if bmk-ov "H" "UNh") bmk-name)))
730 ;; See note in comments of `bmkp-light-bookmarks' - same considerations here.
731 ;; (let ((bmkp-jump-display-function nil)) (bookmark-handle-bookmark bmk))
733 (with-current-buffer (or (and buf (get-buffer buf)) (current-buffer))
735 ;; POINTP is non-nil when `bmkp-light-bookmark' is called from
736 ;; `bookmark--jump-via'.
737 (when (and pointp bmkp-auto-light-relocate-when-jump-flag)
739 (when (and pos (< pos (point-max)))
740 (let ((ov (bmkp-make/move-overlay-of-style styl pos autonamedp)))
741 (when ov ; nil means `none' style.
742 (let ((ovs (if autonamedp
743 'bmkp-autonamed-overlays
744 'bmkp-non-autonamed-overlays)))
745 (push ov (symbol-value ovs)))
746 (when (and (not (bmkp-lighted-p bmk))
747 (> (setq nb-lit (1+ nb-lit)) bmkp-light-threshold))
748 (setq nb-lit (1- nb-lit))
749 (throw 'bmkp-light-bookmark bmk))
750 (overlay-put ov 'priority
751 (or (cdr (assoc (if autonamedp
752 'bmkp-autonamed-overlays
753 'bmkp-non-autonamed-overlays)
754 bmkp-light-priorities))
755 (apply #'min (mapcar #'cdr bmkp-light-priorities))))
756 (unless (memq styl '(lfringe rfringe none)) (overlay-put ov 'face fac))
757 (overlay-put ov 'evaporate t)
758 (overlay-put ov 'category 'bookmark-plus)
759 (overlay-put ov 'bookmark bmk-name))
761 (message "%sighlighted bookmark `%s'" (if ov "H" "UNh") bmk-name)))))))
763 (when msgp (message "Bookmark's condition canceled highlighting"))))))))
766 (defun bmkp-light-bookmark-this-buffer (bookmark &optional style face msgp) ; `C-x p h'
767 "Highlight a BOOKMARK in the current buffer.
768 With a prefix arg you are prompted for the style and/or face to use:
769 Plain prefix arg (`C-u'): prompt for both style and face.
770 Numeric non-negative arg: prompt for face.
771 Numeric negative arg: prompt for style.
772 See `bmkp-light-boookmark' for argument descriptions."
774 (let* ((bmk (bookmark-completing-read "Highlight bookmark" nil (bmkp-this-buffer-alist-only)))
775 (sty (and current-prefix-arg (or (consp current-prefix-arg)
776 (<= (prefix-numeric-value current-prefix-arg) 0))
777 (cdr (assoc (let ((completion-ignore-case t))
779 "Style: " bmkp-light-styles-alist nil t nil nil
780 (and (bmkp-lighting-style bmk)
781 (format "%s" (car (rassq (bmkp-lighting-style bmk)
782 bmkp-light-styles-alist))))))
783 bmkp-light-styles-alist))))
784 (fac (and current-prefix-arg (or (consp current-prefix-arg)
785 (natnump (prefix-numeric-value current-prefix-arg)))
786 (not (member sty '(lfringe rfringe none))) ; No face possible for these.
787 (condition-case nil ; Emacs 22+ accepts a default.
788 (read-face-name "Face: " (format "%S" (bmkp-lighting-face bmk)))
789 (wrong-number-of-arguments (read-face-name "Face: "))))))
790 (list bmk sty fac 'MSG)))
791 (bmkp-light-bookmark bookmark style face msgp))
794 (defun bmkp-light-bookmarks (&optional alist overlays-symbols msgp) ; `C-x p H'
795 "Highlight bookmarks.
796 A prefix argument determines which bookmarks to highlight:
797 none - Current buffer, all bookmarks.
798 = 0 - Current buffer, highlighted bookmarks only (rehighlight).
799 > 0 - Current buffer, autonamed bookmarks only.
800 < 0 - Current buffer, non-autonamed bookmarks only.
801 C-u - All buffers (all bookmarks) - after confirmation.
802 C-u C-u - Navlist (all bookmarks).
804 Non-interactively, ALIST is the alist of bookmarks to highlight."
806 (list (cond ((not current-prefix-arg) (bmkp-this-buffer-alist-only))
807 ((consp current-prefix-arg) (if (> (prefix-numeric-value current-prefix-arg) 4)
811 "Confirm highlighting bookmarks in ALL buffers ")
812 (error "Canceled highlighting"))
813 (bmkp-specific-buffers-alist-only
814 (mapcar #'buffer-name (buffer-list)))))
815 ((> current-prefix-arg 0) (bmkp-autonamed-this-buffer-alist-only))
816 ((< current-prefix-arg 0) (bmkp-remove-if #'bmkp-autonamed-bookmark-p
817 (bmkp-this-buffer-alist-only)))
818 ((= current-prefix-arg 0) (bmkp-this-buffer-lighted-alist-only)))
819 (cond ((or (not current-prefix-arg) (consp current-prefix-arg))
820 '(bmkp-autonamed-overlays bmkp-non-autonamed-overlays))
821 ((natnump current-prefix-arg) '(bmkp-autonamed-overlays))
822 (current-prefix-arg '(bmkp-non-autonamed-overlays)))
824 (unless overlays-symbols
825 (setq overlays-symbols '(bmkp-autonamed-overlays bmkp-non-autonamed-overlays)))
826 (let ((bmkp-use-region nil) ; Inhibit region handling.
832 (nb-lit (bmkp-number-lighted))
833 bmk bmk-name autonamedp face style pos buf bmk-ov passes-when-p)
834 (catch 'bmkp-light-bookmarks
835 (dolist (bookmark alist)
836 (setq bmk (bookmark-get-bookmark bookmark 'noerror)
837 bmk-name (and bmk (bookmark-name-from-full-record bmk))
838 autonamedp (bmkp-autonamed-bookmark-p bmk-name)
839 face (and bmk (bmkp-light-face bmk))
840 style (and bmk (bmkp-light-style bmk))
841 bmk-ov (bmkp-overlay-of-bookmark bmk)
842 passes-when-p (and bmk (or bmk-ov ; Always highlight if already highlighted.
843 (bmkp-light-when bmk))))
844 (when (and bmk passes-when-p) ; Skip bad bookmark and respect `:when' (unless highlighted).
845 (setq pos (bookmark-get-position bmk)
846 buf (bmkp-get-buffer-name bmk))
848 ;; An alternative here would be to call the handler at let it do the highlighting.
849 ;; In that case, we would need at least to bind the display function to nil while
850 ;; handling, so we don't also do the jump. In particular, we don't want to pop to
851 ;; the bookmark in a new window or frame.
852 ;; Calling the handler would be good for some cases, such as Info, where the
853 ;; highlighting is not really specific to the buffer but to a narrowed part of it.
855 ;; (let ((bmkp-jump-display-function nil)) (bookmark-handle-bookmark bmk))
857 ;; But calling the handler is in general the wrong thing. We don't want highlighting
858 ;; all Dired bookmarks in a given directory to also do all the file marking and
859 ;; subdir hiding associated with each of the bookmarks. So we do just the
860 ;; highlighting, no handling, putting the code in side `with-current-buffer'.
861 (with-current-buffer (or (and buf (get-buffer buf)) (current-buffer))
862 (when (and pos (< pos (point-max)))
863 (dolist (ov-symb overlays-symbols)
864 (when (or (and (eq 'bmkp-autonamed-overlays ov-symb) autonamedp)
865 (and (eq 'bmkp-non-autonamed-overlays ov-symb) (not autonamedp)))
866 (let ((ov (bmkp-make/move-overlay-of-style style pos autonamedp bmk-ov)))
867 (when ov ; nil means `none' style.
868 (set ov-symb (cons ov (symbol-value ov-symb)))
869 (when (eq 'bmkp-autonamed-overlays ov-symb)
870 (unless bmk-ov (setq new-auto (1+ new-auto)))
871 (setq nb-auto (1+ nb-auto)))
872 (when (eq 'bmkp-non-autonamed-overlays ov-symb)
873 (unless bmk-ov (setq new-non-auto (1+ new-non-auto)))
874 (setq nb-non-auto (1+ nb-non-auto)))
875 (when (and (not bmk-ov) (> (setq nb-lit (1+ nb-lit)) bmkp-light-threshold))
876 (setq nb-lit (1- nb-lit))
877 (throw 'bmkp-light-bookmarks bmk))
878 (setq total (1+ total))
879 (overlay-put ov 'priority ; > ediff's 100+, < isearch-overlay's 1001.
880 (or (cdr (assoc ov-symb bmkp-light-priorities))
881 (apply #'min (mapcar #'cdr bmkp-light-priorities))))
882 (unless (memq style '(lfringe rfringe none)) (overlay-put ov 'face face))
883 (overlay-put ov 'evaporate t)
884 (overlay-put ov 'category 'bookmark-plus)
885 (overlay-put ov 'bookmark bmk-name)))))))))))
886 (when msgp (message "%s New: %d auto + %d other, Total: %d auto + %d other = %d"
887 (if (consp current-prefix-arg)
888 (if (> (prefix-numeric-value current-prefix-arg) 4)
892 new-auto new-non-auto nb-auto nb-non-auto total))))
895 (defun bmkp-light-navlist-bookmarks (&optional overlays-symbols msgp)
896 "Highlight bookmarks in the navigation list.
897 No prefix arg: all bookmarks.
898 Prefix arg >= 0: autonamed bookmarks only.
899 Prefix arg < 0: non-autonamed bookmarks only."
901 (list (cond ((not current-prefix-arg) '(bmkp-autonamed-overlays bmkp-non-autonamed-overlays))
902 ((natnump (prefix-numeric-value current-prefix-arg)) '(bmkp-autonamed-overlays))
903 (current-prefix-arg '(bmkp-non-autonamed-overlays)))
905 (bmkp-light-bookmarks bmkp-nav-alist overlays-symbols msgp))
908 (defun bmkp-light-this-buffer (&optional overlays-symbols msgp)
909 "Highlight bookmarks in the current buffer.
910 No prefix arg: all bookmarks.
911 Prefix arg >= 0: autonamed bookmarks only.
912 Prefix arg < 0: non-autonamed bookmarks only."
914 (list (cond ((not current-prefix-arg) '(bmkp-autonamed-overlays bmkp-non-autonamed-overlays))
915 ((natnump (prefix-numeric-value current-prefix-arg)) '(bmkp-autonamed-overlays))
916 (current-prefix-arg '(bmkp-non-autonamed-overlays)))
918 (bmkp-light-bookmarks (bmkp-this-buffer-alist-only) overlays-symbols msgp))
921 (defun bmkp-light-bookmarks-in-region (start end &optional overlays-symbols msgp)
922 "Highlight bookmarks in the region.
923 No prefix arg: all bookmarks.
924 Prefix arg >= 0: autonamed bookmarks only.
925 Prefix arg < 0: non-autonamed bookmarks only."
927 (list (region-beginning)
929 (cond ((not current-prefix-arg) '(bmkp-autonamed-overlays bmkp-non-autonamed-overlays))
930 ((natnump (prefix-numeric-value current-prefix-arg)) '(bmkp-autonamed-overlays))
931 (current-prefix-arg '(bmkp-non-autonamed-overlays)))
933 (bmkp-light-bookmarks (bmkp-remove-if-not (lambda (bmk) (let ((pos (bookmark-get-position bmk)))
934 (and (>= pos start) (<= pos end))))
935 (bmkp-this-buffer-alist-only))
936 overlays-symbols msgp))
939 (defun bmkp-light-autonamed-this-buffer (&optional msgp)
940 "Highlight all autonamed bookmarks."
941 (interactive (list 'MSG))
942 (bmkp-light-bookmarks (bmkp-autonamed-this-buffer-alist-only) '(bmkp-autonamed-overlays) msgp))
945 (defun bmkp-light-non-autonamed-this-buffer (&optional msgp)
946 "Highlight all non-autonamed bookmarks."
947 (interactive (list 'MSG))
948 (bmkp-light-bookmarks (bmkp-remove-if #'bmkp-autonamed-bookmark-p (bmkp-this-buffer-alist-only))
949 '(bmkp-non-autonamed-overlays) msgp))
952 (defun bmkp-cycle-lighted-this-buffer (increment &optional other-window startoverp)
953 "Cycle through highlighted bookmarks in this buffer by INCREMENT.
954 Positive INCREMENT cycles forward. Negative INCREMENT cycles backward.
955 Interactively, the prefix arg determines INCREMENT:
957 otherwise: the numeric prefix arg value
959 To change the sort order, you can filter the `*Bookmark List*' to show
960 only highlighted bookmarks for this buffer, sort the bookmarks there,
961 and use `\\[bmkp-choose-navlist-from-bookmark-list]', choosing `CURRENT *Bookmark List*' as the
964 Then you can cycle the bookmarks using `bookmark-cycle'
965 \(`\\[bmkp-next-bookmark-repeat]' etc.), instead of `bookmark-cycle-lighted-this-buffer'.
968 Non-nil OTHER-WINDOW means jump to the bookmark in another window.
969 Non-nil STARTOVERP means reset `bmkp-current-nav-bookmark' to the
970 first bookmark in the navlist."
971 (interactive (let ((startovr (consp current-prefix-arg)))
972 (list (if startovr 1 (prefix-numeric-value current-prefix-arg)) nil startovr)))
973 (bookmark-maybe-load-default-file)
974 (let ((bmkp-sort-comparer bmkp-this-buffer-cycle-sort-comparer))
975 (setq bmkp-nav-alist (bmkp-sort-omit (bmkp-this-buffer-lighted-alist-only))))
976 (unless bmkp-nav-alist (error "No lighted bookmarks for cycling"))
977 (unless (and bmkp-current-nav-bookmark (not startoverp)
978 (bookmark-get-bookmark bmkp-current-nav-bookmark 'NOERROR)
979 (bmkp-this-buffer-p bmkp-current-nav-bookmark)) ; Exclude desktops etc.
980 (setq bmkp-current-nav-bookmark (car bmkp-nav-alist)))
981 (if (bmkp-cycle-1 increment other-window startoverp)
982 (unless (or (bmkp-sequence-bookmark-p bmkp-current-nav-bookmark)
983 (bmkp-function-bookmark-p bmkp-current-nav-bookmark))
984 (message "Position: %9d, Bookmark: `%s'" (point) (bookmark-name-from-full-record
985 bmkp-current-nav-bookmark)))
986 (message "Invalid bookmark: `%s'" (bookmark-name-from-full-record bmkp-current-nav-bookmark))))
989 (defun bmkp-cycle-lighted-this-buffer-other-window (increment &optional startoverp)
990 "Same as `bmkp-cycle-lighted-this-buffer' but uses another window."
991 (interactive (let ((startovr (consp current-prefix-arg)))
992 (list (if startovr 1 (prefix-numeric-value current-prefix-arg)) startovr)))
993 (bmkp-cycle-lighted-this-buffer increment 'OTHER-WINDOW startoverp))
996 (defun bmkp-next-lighted-this-buffer (n &optional startoverp) ; Repeatable key, e.g. `S-f2'
997 "Jump to the Nth-next highlighted bookmark in the current buffer.
998 N defaults to 1, meaning the next one.
999 Plain `C-u' means start over at the first one.
1000 See also `bmkp-cycle-lighted-this-buffer'."
1001 (interactive (let ((startovr (consp current-prefix-arg)))
1002 (list (if startovr 1 (prefix-numeric-value current-prefix-arg)) startovr)))
1003 (bmkp-cycle-lighted-this-buffer n nil startoverp))
1006 (defun bmkp-previous-lighted-this-buffer (n &optional startoverp) ; Repeatable key, e.g. `f2'
1007 "Jump to the Nth-previous highlighted bookmark in the current buffer.
1008 See `bmkp-next-lighted-this-buffer'."
1009 (interactive (let ((startovr (consp current-prefix-arg)))
1010 (list (if startovr 1 (prefix-numeric-value current-prefix-arg)) startovr)))
1011 (bmkp-cycle-lighted-this-buffer (- n) nil startoverp))
1014 (defun bmkp-next-lighted-this-buffer-repeat (arg) ; `C-x p C-down'
1015 "Jump to the Nth next highlighted bookmark in the current buffer.
1016 This is a repeatable version of `bmkp-next-bookmark-this-buffer'.
1017 N defaults to 1, meaning the next one.
1018 Plain `C-u' means start over at the first one (and no repeat)."
1021 (bmkp-repeat-command 'bmkp-next-lighted-this-buffer))
1024 (defun bmkp-previous-lighted-this-buffer-repeat (arg) ; `C-x p C-up'
1025 "Jump to the Nth previous highlighted bookmark in the current buffer.
1026 See `bmkp-next-lighted-this-buffer-repeat'."
1029 (bmkp-repeat-command 'bmkp-previous-lighted-this-buffer))
1032 ;;(@* "Other Functions")
1033 ;; *** Other Functions ***
1035 (defun bmkp-light-face (bookmark)
1036 "Return the face to use to highlight BOOKMARK.
1037 BOOKMARK is a bookmark name or a bookmark record.
1039 nil if BOOKMARK is not a valid bookmark;
1040 the `:face' specified by BOOKMARK's `lighting' property, if any;
1041 `bmkp-light-autonamed' if BOOKMARK is an autonamed bookmark;
1042 or `bmkp-light-non-autonamed' otherwise."
1043 (setq bookmark (bookmark-get-bookmark bookmark 'noerror))
1044 (or (bmkp-lighting-face bookmark)
1045 (and bookmark (if (string-match (format bmkp-autoname-format ".*")
1046 (bookmark-name-from-full-record bookmark))
1047 'bmkp-light-autonamed
1048 'bmkp-light-non-autonamed))))
1050 (defun bmkp-light-style (bookmark)
1051 "Return the style to use to highlight BOOKMARK.
1052 BOOKMARK is a bookmark name or a bookmark record.
1054 nil if BOOKMARK is not a valid bookmark;
1055 the `:style' specified by BOOKMARK's `lighting' property, if any;
1056 the value of `bmkp-light-style-autonamed' if autonamed;
1057 or the value of `bmkp-light-style-non-autonamed' otherwise."
1058 (setq bookmark (bookmark-get-bookmark bookmark 'noerror))
1059 (or (bmkp-lighting-style bookmark)
1060 (and bookmark (if (string-match (format bmkp-autoname-format ".*")
1061 (bookmark-name-from-full-record bookmark))
1062 bmkp-light-style-autonamed
1063 bmkp-light-style-non-autonamed))))
1065 (defun bmkp-light-when (bookmark)
1066 "Return non-nil if BOOKMARK should be highlighted.
1067 BOOKMARK's `:when' condition is used to determine this.
1068 BOOKMARK is a bookmark name or a bookmark record."
1069 (setq bookmark (bookmark-get-bookmark bookmark 'noerror))
1070 (let ((this-bookmark bookmark)
1071 (this-bookmark-name (bookmark-name-from-full-record bookmark))
1072 (when-sexp (bmkp-lighting-when bookmark)))
1073 (not (eq :no-light (eval when-sexp)))))
1075 (defun bmkp-lighting-face (bookmark)
1076 "`:face' specified by BOOKMARK's `lighting', or nil if no `:face' entry.
1077 BOOKMARK is a bookmark name or a bookmark record.
1079 The `:face' entry is the face (a symbol) used to highlight BOOKMARK.
1080 Alternatively, it can be `auto' or nil, which both mean the same as
1081 having no `:face' entry: do not override automatic face choice."
1082 (bmkp-lighting-attribute bookmark :face))
1084 (defun bmkp-lighting-style (bookmark)
1085 "`:style' specified by BOOKMARK's `lighting', or nil if no `:style' entry.
1086 BOOKMARK is a bookmark name or a bookmark record.
1088 The `:style' entry is the style used to highlight BOOKMARK.
1089 It is a value acceptable for `bmkp-light-style-non-autonamed'.
1090 Alternatively, it can be `auto' or nil, which both mean the same as
1091 having no `:style' entry: do not override automatic style choice."
1092 (bmkp-lighting-attribute bookmark :style))
1094 (defun bmkp-lighting-when (bookmark)
1095 "`:when' specified by BOOKMARK's `lighting', or nil if no `:when' entry.
1096 BOOKMARK is a bookmark name or a bookmark record.
1098 The `:when' entry is a sexp that is eval'd when you try to highlight
1099 BOOKMARK. If the result is the symbol `:no-light', then do not
1100 highlight. Otherwise, highlight. (Note that highlighting happens if
1101 the value is nil or there is no `:when' entry.)"
1102 (bmkp-lighting-attribute bookmark :when))
1104 (defun bmkp-lighting-attribute (bookmark attribute)
1105 "ATTRIBUTE specified by BOOKMARK's `lighting', or nil if no such attribute.
1106 BOOKMARK is a bookmark name or a bookmark record.
1107 ATTRIBUTE is `:style' or `:face'."
1108 (setq bookmark (bookmark-get-bookmark bookmark 'noerror))
1109 (let* ((lighting (and bookmark (bmkp-get-lighting bookmark)))
1110 (attr (and (consp lighting) (plist-get lighting attribute))))
1111 (when (and (eq 'auto attr) (not (eq :when attribute))) (setq attr nil))
1114 (defun bmkp-get-lighting (bookmark)
1115 "Return the `lighting' property list for BOOKMARK.
1116 This is the cdr of the `lighting' entry (i.e. with `lighting' removed).
1117 BOOKMARK is a bookmark name or a bookmark record."
1118 (bookmark-prop-get bookmark 'lighting))
1120 (defun bmkp-bookmark-overlay-p (overlay)
1121 "Return non-nil if OVERLAY is a bookmark overlay."
1122 (and (overlayp overlay) (overlay-get overlay 'bookmark)))
1124 (defun bmkp-default-lighted ()
1125 "Return a highlighted bookmark at point or on this line, or nil if none.
1126 For Emacs 23+, if there is a highlighted bookmark at point, return a
1128 (or (if (> emacs-major-version 22)
1129 (bmkp-bookmarks-lighted-at-point)
1130 (bmkp-a-bookmark-lighted-at-pos))
1131 (bmkp-a-bookmark-lighted-on-this-line)))
1133 (defun bmkp-a-bookmark-lighted-on-this-line (&optional fullp msgp)
1134 "Return a bookmark highlighted on the current line or nil if none.
1135 The search for a highlighted bookmark moves left to bol from point,
1136 then right to eol from point.
1137 Return the bookmark name or, if FULLP non-nil, the full bookmark data."
1139 (bol (1+ (line-beginning-position)))
1140 (eol (1- (line-end-position)))
1142 (catch 'bmkp-a-bookmark-lighted-on-this-line
1144 (when (setq bmk (bmkp-a-bookmark-lighted-at-pos pos))
1145 (throw 'bmkp-a-bookmark-lighted-on-this-line bmk))
1146 (setq pos (1- pos)))
1148 (when (setq bmk (bmkp-a-bookmark-lighted-at-pos pos))
1149 (throw 'bmkp-a-bookmark-lighted-on-this-line bmk))
1150 (setq pos (1+ pos)))
1152 (when (and bmk fullp) (setq bmk (bookmark-get-bookmark bmk)))
1155 (defun bmkp-a-bookmark-lighted-at-pos (&optional position fullp)
1156 "Return a bookmark highlighted at POSITION or nil if none.
1157 POSITION defaults to point.
1158 Return the bookmark name or, if FULLP non-nil, the full bookmark data."
1159 (unless position (setq position (point)))
1161 (catch 'bmkp-a-bookmark-lighted-at-pos
1162 (dolist (ov (overlays-at position))
1163 (when (setq bmk (overlay-get ov 'bookmark))
1164 (throw 'bmkp-a-bookmark-lighted-at-pos bmk)))
1166 (when (and bmk fullp) (setq bmk (bookmark-get-bookmark bmk)))
1169 (defun bmkp-read-set-lighting-args (&optional default-style default-face default-when)
1170 "Read args STYLE, FACE, and WHEN for commands that set `lighting' prop.
1171 Optional args are the default values (strings) for reading new values."
1172 (let* ((icicle-unpropertize-completion-result-flag t)
1173 (style (cdr (assoc (let ((completion-ignore-case t))
1174 (completing-read "Style: " bmkp-light-styles-alist
1175 nil t nil nil default-style))
1176 bmkp-light-styles-alist)))
1177 (face (and (not (member style '(lfringe rfringe none))) ; No face possible for these.
1178 (y-or-n-p "Change face? ") ; Allow nil, for `auto'.
1179 (condition-case nil ; Emacs 22+ accepts a default.
1180 (read-face-name "Face: " default-face)
1181 (wrong-number-of-arguments (read-face-name "Face: ")))))
1182 (when-cands `(("auto" . nil)
1183 ("conditionally (read sexp)")
1184 ("never" . :no-light)))
1185 (when (completing-read "When: " when-cands nil t nil nil
1186 (if default-when "conditionally (read sexp)" "auto")))
1187 (evald (if (string-match "^con" when)
1188 (read-from-minibuffer "Highlight when (sexp): " nil
1189 (if (boundp 'pp-read-expression-map)
1190 pp-read-expression-map
1191 read-expression-map)
1192 t 'read-expression-history default-when)
1193 (cdr (assoc when when-cands)))))
1194 (list style face evald)))
1196 (defun bmkp-lighted-alist-only ()
1197 "`bookmark-alist', with only highlighted bookmarks.
1198 A new list is returned (no side effects)."
1199 (bookmark-maybe-load-default-file)
1200 (bmkp-remove-if-not (lambda (bmk) (bmkp-lighted-p bmk)) bookmark-alist))
1202 (defun bmkp-this-buffer-lighted-alist-only ()
1203 "`bookmark-alist', with only highlighted bookmarks for current buffer.
1204 A new list is returned (no side effects)."
1205 (bookmark-maybe-load-default-file)
1206 (bmkp-remove-if-not (lambda (bmk) (and (bmkp-this-buffer-p bmk) (bmkp-lighted-p bmk)))
1209 (defun bmkp-number-lighted (&optional overlays-symbols)
1210 "Number of bookmarks highlighted."
1211 (unless overlays-symbols
1212 (setq overlays-symbols '(bmkp-autonamed-overlays bmkp-non-autonamed-overlays)))
1214 (dolist (ov-symb overlays-symbols)
1215 (dolist (ov (symbol-value ov-symb)) (when (overlay-buffer ov) (setq count (1+ count)))))
1218 (defalias 'bmkp-lighted-p 'bmkp-overlay-of-bookmark)
1219 (defun bmkp-overlay-of-bookmark (bookmark &optional overlays)
1220 "Return the overlay for BOOKMARK in OVERLAYS, or nil if none.
1221 BOOKMARK is a bookmark name or a bookmark record.
1222 Optional arg OVERLAYS is the list of overlays to check.
1223 If nil, check overlays for both autonamed and non-autonamed bookmarks."
1224 (setq bookmark (bookmark-get-bookmark bookmark 'noerror))
1225 (and bookmark ; Return nil for a bad bookmark.
1226 (setq bookmark (bookmark-name-from-full-record bookmark))
1227 (catch 'bmkp-overlay-of-bookmark
1228 (dolist (ov (if overlays
1229 (apply #'append (mapcar #'symbol-value overlays))
1230 (append bmkp-autonamed-overlays bmkp-non-autonamed-overlays)))
1231 (when (and (overlay-buffer ov) (equal bookmark (overlay-get ov 'bookmark)))
1232 (throw 'bmkp-overlay-of-bookmark ov)))
1235 (defun bmkp-make/move-overlay-of-style (style pos autonamedp &optional overlay)
1236 "Return a bookmark overlay of STYLE at bookmark position POS.
1237 AUTONAMEDP non-nil means the bookmark is autonamed.
1238 If OVERLAY is non-nil it is the overlay to use - change to STYLE.
1239 Otherwise, create a new overlay.
1240 If STYLE is `none' then:
1241 If OVERLAY is non-nil, delete it.
1244 (when (and (< emacs-major-version 22) (not (rassq style bmkp-light-styles-alist)))
1245 (message "Fringe styles not supported before Emacs 22 - changing to `line' style")
1249 (setq ov (save-excursion
1251 (progn (goto-char pos) (line-beginning-position 1))
1252 (progn (goto-char pos) (line-beginning-position 2)))))
1253 (overlay-put ov 'before-string nil) ; Remove any fringe highlighting.
1256 (progn (goto-char pos) (line-beginning-position 1))
1257 (progn (goto-char pos) (line-beginning-position 2))))))
1258 (lfringe (setq ov (bmkp-make/move-fringe 'left pos autonamedp ov)))
1259 (rfringe (setq ov (bmkp-make/move-fringe 'right pos autonamedp ov)))
1260 (line+lfringe (setq ov (bmkp-make/move-fringe 'left pos autonamedp ov 'LINEP)))
1261 (line+rfringe (setq ov (bmkp-make/move-fringe 'right pos autonamedp ov 'LINEP)))
1263 (setq ov (save-excursion (goto-char pos)
1264 (make-overlay (line-beginning-position)
1265 (1+ (line-beginning-position)))))
1266 (overlay-put ov 'before-string nil) ; Remove any fringe highlighting.
1267 (save-excursion (goto-char pos)
1268 (move-overlay ov (line-beginning-position)
1269 (1+ (line-beginning-position))))))
1271 (setq ov (make-overlay pos (1+ pos)))
1272 (overlay-put ov 'before-string nil) ; Remove any fringe highlighting.
1273 (move-overlay ov pos (1+ pos))))
1274 (none (when ov (delete-overlay ov)) (setq ov nil)))
1277 ;; Not used for Emacs 20-21.
1278 (defun bmkp-make/move-fringe (side pos autonamedp &optional overlay linep)
1279 "Return an overlay that uses the fringe.
1280 If SIDE is `right' then use the right fringe, otherwise left.
1281 POS is the overlay position.
1282 AUTONAMEDP: non-nil means use face `bmkp-light-fringe-autonamed'.
1283 nil means use face `bmkp-light-fringe-non-autonamed'.
1284 If OVERLAY is non-nil it is the overlay to use.
1285 Otherwise, create a new overlay.
1286 Non-nil LINEP means also highlight the line containing POS."
1287 (unless (> emacs-major-version 21) (error "Fringe styles not supported before Emacs 22"))
1290 (save-excursion (move-overlay overlay (progn (goto-char pos)
1291 (goto-char (line-beginning-position)))
1293 (setq ov (save-excursion (make-overlay (progn (goto-char pos)
1294 (goto-char (line-beginning-position)))
1296 (overlay-put ov 'before-string (bmkp-fringe-string side autonamedp))
1298 (move-overlay ov (save-excursion (goto-char pos) (line-beginning-position 1))
1299 (save-excursion (goto-char pos) (line-beginning-position 2)))
1300 (overlay-put ov 'face nil)) ; Remove any non-fringe highlighting.
1303 ;; Not used for Emacs 20-21.
1304 (defun bmkp-fringe-string (side autonamedp)
1305 "Return a fringe string for a bookmark overlay.
1306 If SIDE is `right' then use the right fringe, otherwise left.
1307 AUTONAMEDP: non-nil means use face `bmkp-light-fringe-autonamed'.
1308 nil means use face `bmkp-light-fringe-non-autonamed'."
1309 (unless (> emacs-major-version 21) (error "Fringe styles not supported before Emacs 22"))
1310 (let ((fringe-string (copy-sequence (if autonamedp "*AUTO*" "*NONAUTO*"))))
1311 (put-text-property 0 (length fringe-string)
1312 'display (if (eq side 'right)
1314 bmkp-light-right-fringe-bitmap
1316 'bmkp-light-fringe-autonamed
1317 'bmkp-light-fringe-non-autonamed))
1319 bmkp-light-left-fringe-bitmap
1321 'bmkp-light-fringe-autonamed
1322 'bmkp-light-fringe-non-autonamed)))
1328 (provide 'bookmark+-lit)
1330 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1331 ;;; bookmark+-lit.el ends here