.emacs.d/elisp/icicle/bookmark+-mac.el

   1 ;;; bookmark+-mac.el --- Macros for Bookmark+.
   2 ;;
   3 ;; Filename: bookmark+-mac.el
   4 ;; Description: Macros for Bookmark+.
   5 ;; Author: Drew Adams
   6 ;; Maintainer: Drew Adams
   7 ;; Copyright (C) 2000-2012, Drew Adams, all rights reserved.
   8 ;; Created: Sun Aug 15 11:12:30 2010 (-0700)
   9 ;; Last-Updated: Fri Apr 27 17:25:39 2012 (-0700)
  10 ;;           By: dradams
  11 ;;     Update #: 97
  12 ;; URL: http://www.emacswiki.org/cgi-bin/wiki/bookmark+-mac.el
  13 ;; Keywords: bookmarks, bookmark+, placeholders, annotations, search, info, url, w3m, gnus
  14 ;; Compatibility: GNU Emacs: 20.x, 21.x, 22.x, 23.x
  15 ;;
  16 ;; Features that might be required by this library:
  17 ;;
  18 ;;   `bookmark', `pp'.
  19 ;;
  20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21 ;;
  22 ;;; Commentary:
  23 ;;
  24 ;;    Macros for Bookmark+.
  25 ;;
  26 ;;    The Bookmark+ libraries are these:
  27 ;;
  28 ;;    `bookmark+.el'     - main (driver) library
  29 ;;    `bookmark+-mac.el' - Lisp macros (this file)
  30 ;;    `bookmark+-bmu.el' - code for the `*Bookmark List*' (bmenu)
  31 ;;    `bookmark+-1.el'   - other (non-bmenu) required code
  32 ;;    `bookmark+-lit.el' - (optional) code for highlighting bookmarks
  33 ;;    `bookmark+-key.el' - key and menu bindings
  34 ;;
  35 ;;    `bookmark+-doc.el' - documentation (comment-only file)
  36 ;;    `bookmark+-chg.el' - change log (comment-only file)
  37 ;;
  38 ;;    The documentation (in `bookmark+-doc.el') includes how to
  39 ;;    byte-compile and install Bookmark+.  The documentation is also
  40 ;;    available in these ways:
  41 ;;
  42 ;;    1. From the bookmark list (`C-x r l'):
  43 ;;       Use `?' to show the current bookmark-list status and general
  44 ;;       help, then click link `Doc in Commentary' or link `Doc on the
  45 ;;       Web'.
  46 ;;
  47 ;;    2. From the Emacs-Wiki Web site:
  48 ;;       http://www.emacswiki.org/cgi-bin/wiki/BookmarkPlus.
  49 ;;
  50 ;;    3. From the Bookmark+ group customization buffer:
  51 ;;       `M-x customize-group bookmark-plus', then click link
  52 ;;       `Commentary'.
  53 ;;
  54 ;;    (The commentary links in #1 and #3 work only if you have library
  55 ;;    `bookmark+-doc.el' in your `load-path'.)
  56 ;;
  57 ;;
  58 ;;    ****** NOTE ******
  59 ;;
  60 ;;      WHENEVER you update Bookmark+ (i.e., download new versions of
  61 ;;      Bookmark+ source files), I recommend that you do the
  62 ;;      following:
  63 ;;
  64 ;;      1. Delete ALL existing BYTE-COMPILED Bookmark+ files
  65 ;;         (bookmark+*.elc).
  66 ;;      2. Load Bookmark+ (`load-library' or `require').
  67 ;;      3. Byte-compile the source files.
  68 ;;
  69 ;;      In particular, ALWAYS LOAD `bookmark+-mac.el' (not
  70 ;;      `bookmark+-mac.elc') BEFORE YOU BYTE-COMPILE new versions of
  71 ;;      the files, in case there have been any changes to Lisp macros
  72 ;;      (in `bookmark+-mac.el').
  73 ;;
  74 ;;      (This is standard procedure for Lisp: code that depends on
  75 ;;      macros needs to be byte-compiled anew after loading the
  76 ;;      updated macros.)
  77 ;;
  78 ;;    ******************
  79
  80 ;;(@> "Index")
  81 ;;
  82 ;;  If you have library `linkd.el' and Emacs 22 or later, load
  83 ;;  `linkd.el' and turn on `linkd-mode' now.  It lets you easily
  84 ;;  navigate around the sections of this doc.  Linkd mode will
  85 ;;  highlight this Index, as well as the cross-references and section
  86 ;;  headings throughout this file.  You can get `linkd.el' here:
  87 ;;  http://dto.freeshell.org/notebook/Linkd.html.
  88 ;;
  89 ;;  (@> "Things Defined Here")
  90 ;;  (@> "Functions")
  91 ;;  (@> "Macros")
  92
  93 ;;(@* "Things Defined Here")
  94 ;;
  95 ;;  Things Defined Here
  96 ;;  -------------------
  97 ;;
  98 ;;  Macros defined here:
  99 ;;
 100 ;;    `bmkp-define-cycle-command',
 101 ;;    `bmkp-define-next+prev-cycle-commands',
 102 ;;    `bmkp-define-sort-command', `bmkp-define-file-sort-predicate',
 103 ;;    `bmkp-menu-bar-make-toggle',
 104 ;;    `bmkp-with-output-to-plain-temp-buffer'.
 105 ;;
 106 ;;  Non-interactive functions defined here:
 107 ;;
 108 ;;    `bmkp-assoc-delete-all', `bmkp-replace-regexp-in-string'.
 109 ;;
 110 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 111 ;;
 112 ;; This program is free software; you can redistribute it and/or
 113 ;; modify it under the terms of the GNU General Public License as
 114 ;; published by the Free Software Foundation; either version 3, or
 115 ;; (at your option) any later version.
 116 ;;
 117 ;; This program is distributed in the hope that it will be useful,
 118 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 119 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 120 ;; General Public License for more details.
 121 ;;
 122 ;; You should have received a copy of the GNU General Public License
 123 ;; along with this program; see the file COPYING.  If not, write to
 124 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
 125 ;; Floor, Boston, MA 02110-1301, USA.
 126 ;;
 127 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 128 ;;
 129 ;;; Code:
 130
 131 ;;;;;;;;;;;;;;;;;;;;;;;
 132
 133 (require 'bookmark)
 134 ;; bookmark-bmenu-bookmark, bookmark-bmenu-ensure-position,
 135 ;; bookmark-bmenu-surreptitiously-rebuild-list, bookmark-get-bookmark,
 136 ;; bookmark-get-filename
 137
 138
 139 ;; Some general Renamings.
 140 ;;
 141 ;; 1. Fix incompatibility introduced by gratuitous Emacs name change.
 142 ;;
 143 (cond ((and (fboundp 'bookmark-name-from-record) (not (fboundp 'bookmark-name-from-full-record)))
 144        (defalias 'bookmark-name-from-full-record 'bookmark-name-from-record))
 145       ((and (fboundp 'bookmark-name-from-full-record) (not (fboundp 'bookmark-name-from-record)))
 146        (defalias 'bookmark-name-from-record 'bookmark-name-from-full-record)))
 147
 148 ;; 2. The vanilla name of the first is misleading, as it returns only the cdr of the record.
 149 ;;    The second is for consistency.
 150 ;;
 151 (defalias 'bmkp-bookmark-data-from-record 'bookmark-get-bookmark-record)
 152 (defalias 'bmkp-bookmark-name-from-record 'bookmark-name-from-full-record)
 153
 154
 155 ;; (eval-when-compile (require 'bookmark+-bmu))
 156 ;; bmkp-bmenu-barf-if-not-in-menu-list,
 157 ;; bmkp-bmenu-goto-bookmark-named, bmkp-sort-orders-alist
 158
 159 ;; (eval-when-compile (require 'bookmark+-1))
 160 ;; bmkp-file-bookmark-p, bmkp-float-time, bmkp-local-file-bookmark-p,
 161 ;; bmkp-msg-about-sort-order, bmkp-reverse-sort-p, bmkp-sort-comparer
 162
 163 ;;(@* "Functions")
 164
 165 ;;; Functions --------------------------------------------------------
 166
 167 ;;; These functions are general functions.  They are here because they are used in macro
 168 ;;; `bmkp-define-sort-command'.  That macro is in this file because it is used only to create
 169 ;;; bmenu commands.
 170
 171 ;; Used in `bmkp-define-sort-command'.
 172 (defun bmkp-assoc-delete-all (key alist)
 173   "Delete from ALIST all elements whose car is `equal' to KEY.
 174 Return the modified alist.
 175 Elements of ALIST that are not conses are ignored."
 176   (while (and (consp (car alist)) (equal (car (car alist)) key))  (setq alist  (cdr alist)))
 177   (let ((tail  alist)
 178         tail-cdr)
 179     (while (setq tail-cdr  (cdr tail))
 180       (if (and (consp (car tail-cdr))  (equal (car (car tail-cdr)) key))
 181           (setcdr tail (cdr tail-cdr))
 182         (setq tail  tail-cdr))))
 183   alist)
 184
 185 ;; Used in `bmkp-define-sort-command'.
 186 (defun bmkp-replace-regexp-in-string (regexp rep string &optional fixedcase literal subexp start)
 187   "Replace all matches for REGEXP with REP in STRING and return STRING."
 188   (if (fboundp 'replace-regexp-in-string) ; Emacs > 20.
 189       (replace-regexp-in-string regexp rep string fixedcase literal subexp start)
 190     (if (string-match regexp string) (replace-match rep nil nil string) string))) ; Emacs 20
 191
 192 ;;(@* "Macros")
 193
 194 ;;; Macros -----------------------------------------------------------
 195
 196 ;;;###autoload
 197 (defmacro bmkp-with-output-to-plain-temp-buffer (buf &rest body)
 198   "Like `with-output-to-temp-buffer', but with no *Help* navigation stuff."
 199   `(unwind-protect
 200     (progn
 201       (remove-hook 'temp-buffer-setup-hook 'help-mode-setup)
 202       (remove-hook 'temp-buffer-show-hook  'help-mode-finish)
 203       (with-output-to-temp-buffer ,buf ,@body))
 204     (add-hook 'temp-buffer-setup-hook 'help-mode-setup)
 205     (add-hook 'temp-buffer-show-hook  'help-mode-finish)))
 206
 207 ;;;###autoload
 208 (defmacro bmkp-define-cycle-command (type &optional otherp)
 209   "Define a cycling command for bookmarks of type TYPE.
 210 Non-nil OTHERP means define a command that cycles in another window."
 211   `(defun ,(intern (format "bmkp-cycle-%s%s" type (if otherp "-other-window" "")))
 212     (increment &optional startoverp)
 213     ,(if otherp
 214          (format "Same as `bmkp-cycle-%s', but use other window." type)
 215          (format "Cycle through %s bookmarks by INCREMENT (default: 1).
 216 Positive INCREMENT cycles forward.  Negative INCREMENT cycles backward.
 217 Interactively, the prefix arg determines INCREMENT:
 218  Plain `C-u': 1
 219  otherwise: the numeric prefix arg value
 220
 221 Plain `C-u' also means start over at first bookmark.
 222
 223 In Lisp code:
 224  Non-nil STARTOVERP means reset `bmkp-current-nav-bookmark' to the
 225  first bookmark in the navlist." type))
 226     (interactive (let ((startovr  (consp current-prefix-arg)))
 227                    (list (if startovr 1 (prefix-numeric-value current-prefix-arg))
 228                          startovr)))
 229     (let ((bmkp-nav-alist  (bmkp-sort-omit (,(intern (format "bmkp-%s-alist-only" type))))))
 230       (bmkp-cycle increment ,otherp startoverp))))
 231
 232 ;;;###autoload
 233 (defmacro bmkp-define-next+prev-cycle-commands (type)
 234   "Define `next' and `previous' commands for bookmarks of type TYPE."
 235   `(progn
 236     ;; `next' command.
 237     (defun ,(intern (format "bmkp-next-%s-bookmark" type)) (n &optional startoverp)
 238       ,(format "Jump to the Nth-next %s bookmark.
 239 N defaults to 1, meaning the next one.
 240 Plain `C-u' means start over at the first one.
 241 See also `bmkp-cycle-%s'." type type)
 242       (interactive (let ((startovr  (consp current-prefix-arg)))
 243                      (list (if startovr 1 (prefix-numeric-value current-prefix-arg)) startovr)))
 244       (,(intern (format "bmkp-cycle-%s" type)) n startoverp))
 245
 246     ;; `previous' command.
 247     (defun ,(intern (format "bmkp-previous-%s-bookmark" type)) (n &optional startoverp)
 248       ,(format "Jump to the Nth-previous %s bookmark.
 249 See `bmkp-next-%s-bookmark'." type type)
 250       (interactive (let ((startovr  (consp current-prefix-arg)))
 251                      (list (if startovr 1 (prefix-numeric-value current-prefix-arg)) startovr)))
 252       (,(intern (format "bmkp-cycle-%s" type)) (- n) startoverp))
 253
 254     ;; `next' repeating command.
 255     (defun ,(intern (format "bmkp-next-%s-bookmark-repeat" type)) (arg)
 256       ,(format "Jump to the Nth-next %s bookmark.
 257 This is a repeatable version of `bmkp-next-%s-bookmark'.
 258 N defaults to 1, meaning the next one.
 259 Plain `C-u' means start over at the first one (and no repeat)." type type)
 260       (interactive "P")
 261       (require 'repeat)
 262       (bmkp-repeat-command ',(intern (format "bmkp-next-%s-bookmark" type))))
 263
 264     ;; `previous repeating command.
 265     (defun ,(intern (format "bmkp-previous-%s-bookmark-repeat" type)) (arg)
 266       ,(format "Jump to the Nth-previous %s bookmark.
 267 See `bmkp-next-%s-bookmark-repeat'." type type)
 268       (interactive "P")
 269       (require 'repeat)
 270       (bmkp-repeat-command ',(intern (format "bmkp-previous-%s-bookmark" type))))))
 271
 272 ;;;###autoload
 273 (defmacro bmkp-define-sort-command (sort-order comparer doc-string)
 274   "Define a command to sort bookmarks in the bookmark list by SORT-ORDER.
 275 SORT-ORDER is a short string or symbol describing the sorting method.
 276 Examples: \"by last access time\", \"by bookmark name\".
 277
 278 The new command is named by replacing any spaces in SORT-ORDER with
 279 hyphens (`-') and then adding the prefix `bmkp-bmenu-sort-'.  Example:
 280 `bmkp-bmenu-sort-by-bookmark-name', for SORT-ORDER `by bookmark name'.
 281
 282 COMPARER compares two bookmarks, returning non-nil if and only if the
 283 first bookmark sorts before the second.  It must be acceptable as a
 284 value of `bmkp-sort-comparer'.  That is, it is either nil, a
 285 predicate, or a list ((PRED...) FINAL-PRED).  See the doc for
 286 `bmkp-sort-comparer'.
 287
 288 DOC-STRING is the doc string of the new command."
 289   (unless (stringp sort-order) (setq sort-order  (symbol-name sort-order)))
 290   (let ((command  (intern (concat "bmkp-bmenu-sort-" (bmkp-replace-regexp-in-string
 291                                                       "\\s-+" "-" sort-order)))))
 292     `(progn
 293       (setq bmkp-sort-orders-alist  (bmkp-assoc-delete-all ,sort-order (copy-sequence
 294                                                                         bmkp-sort-orders-alist)))
 295       (push (cons ,sort-order ',comparer) bmkp-sort-orders-alist)
 296       (defun ,command ()
 297         ,(concat doc-string "\nRepeating this command cycles among normal sort, reversed \
 298 sort, and unsorted.")
 299         (interactive)
 300         (bmkp-bmenu-barf-if-not-in-menu-list)
 301         (cond (;; Not this sort order - make it this sort order.
 302                (not (equal bmkp-sort-comparer ',comparer))
 303                (setq bmkp-sort-comparer   ',comparer
 304                      bmkp-reverse-sort-p  nil))
 305               (;; Not this sort order reversed - make it reversed.
 306                (not bmkp-reverse-sort-p)
 307                (setq bmkp-reverse-sort-p  t))
 308               (t;; This sort order reversed.  Change to unsorted.
 309                (setq bmkp-sort-comparer   nil)))
 310         (message "Sorting...")
 311         (bookmark-bmenu-ensure-position)
 312         (let ((current-bmk  (bookmark-bmenu-bookmark)))
 313           (bookmark-bmenu-surreptitiously-rebuild-list)
 314           (when current-bmk             ; Should be non-nil, but play safe.
 315             (bmkp-bmenu-goto-bookmark-named current-bmk))) ; Put cursor back on right line.
 316         (when (interactive-p)
 317           (bmkp-msg-about-sort-order
 318            ,sort-order
 319            nil
 320            (cond ((and (not bmkp-reverse-sort-p)
 321                        (equal bmkp-sort-comparer ',comparer)) "(Repeat: reverse)")
 322                  ((equal bmkp-sort-comparer ',comparer)       "(Repeat: unsorted)")
 323                  (t                                           "(Repeat: sort)"))))))))
 324
 325 ;;;###autoload
 326 (defmacro bmkp-define-file-sort-predicate (att-nb)
 327   "Define a predicate for sorting bookmarks by file attribute ATT-NB.
 328 See function `file-attributes' for the meanings of the various file
 329 attribute numbers.
 330
 331 String attribute values sort alphabetically; numerical values sort
 332 numerically; nil sorts before t.
 333
 334 For ATT-NB 0 (file type), a file sorts before a symlink, which sorts
 335 before a directory.
 336
 337 For ATT-NB 2 or 3 (uid, gid), a numerical value sorts before a string
 338 value.
 339
 340 A bookmark that has file attributes sorts before a bookmark that does
 341 not.  A file bookmark sorts before a non-file bookmark.  Only local
 342 files are tested for attributes - remote-file bookmarks are treated
 343 here like non-file bookmarks."
 344   `(defun ,(intern (format "bmkp-file-attribute-%d-cp" att-nb)) (b1 b2)
 345     ,(format "Sort file bookmarks by attribute %d.
 346 Sort bookmarks with file attributes before those without attributes
 347 Sort file bookmarks before non-file bookmarks.
 348 Treat remote file bookmarks like non-file bookmarks.
 349
 350 B1 and B2 are full bookmarks (records) or bookmark names.
 351 If either is a record then it need not belong to `bookmark-alist'."
 352              att-nb)
 353     (setq b1  (bookmark-get-bookmark b1))
 354     (setq b2  (bookmark-get-bookmark b2))
 355     (let (a1 a2)
 356       (cond (;; Both are file bookmarks.
 357              (and (bmkp-file-bookmark-p b1) (bmkp-file-bookmark-p b2))
 358              (setq a1  (file-attributes (bookmark-get-filename b1))
 359                    a2  (file-attributes (bookmark-get-filename b2)))
 360              (cond (;; Both have attributes.
 361                     (and a1 a2)
 362                     (setq a1  (nth ,att-nb a1)
 363                           a2  (nth ,att-nb a2))
 364                     ;; Convert times and maybe inode number to floats.
 365                     ;; The inode conversion is kludgy, but is probably OK in practice.
 366                     (when (consp a1) (setq a1  (bmkp-float-time a1)))
 367                     (when (consp a2) (setq a2  (bmkp-float-time a2)))
 368                     (cond (;; (1) links, (2) maybe uid, (3) maybe gid, (4, 5, 6) times
 369                            ;; (7) size, (10) inode, (11) device.
 370                            (numberp a1)
 371                            (cond ((< a1 a2)  '(t))
 372                                  ((> a1 a2)  '(nil))
 373                                  (t          nil)))
 374                           ((= 0 ,att-nb) ; (0) file (nil) < symlink (string) < dir (t)
 375                            (cond ((and a2 (not a1))               '(t)) ; file vs (symlink or dir)
 376                                  ((and a1 (not a2))               '(nil))
 377                                  ((and (eq t a2) (not (eq t a1))) '(t)) ; symlink vs dir
 378                                  ((and (eq t a1) (not (eq t a2))) '(t))
 379                                  ((and (stringp a1) (stringp a2))
 380                                   (if (string< a1 a2) '(t) '(nil)))
 381                                  (t                               nil)))
 382                           ((stringp a1) ; (2, 3) string uid/gid, (8) modes
 383                            (cond ((string< a1 a2)  '(t))
 384                                  ((string< a2 a1)  '(nil))
 385                                  (t                nil)))
 386                           ((eq ,att-nb 9) ; (9) gid would change if re-created. nil < t
 387                            (cond ((and a2 (not a1))  '(t))
 388                                  ((and a1 (not a2))  '(nil))
 389                                  (t                  nil)))))
 390                    (;; First has attributes, but not second.
 391                     a1
 392                     '(t))
 393                    (;; Second has attributes, but not first.
 394                     a2
 395                     '(nil))
 396                    (;; Neither has attributes.
 397                     t
 398                     nil)))
 399             (;; First is a file, second is not.
 400              (bmkp-local-file-bookmark-p b1)
 401              '(t))
 402             (;; Second is a file, first is not.
 403              (bmkp-local-file-bookmark-p b2)
 404              '(nil))
 405             (t;; Neither is a file.
 406              nil)))))
 407
 408 ;;;###autoload
 409 (defmacro bmkp-menu-bar-make-toggle (name variable doc message help &rest body)
 410   "Return a valid `menu-bar-make-toggle' call in Emacs 20 or later.
 411 NAME is the name of the toggle command to define.
 412 VARIABLE is the variable to set.
 413 DOC is the menu-item name.
 414 MESSAGE is the toggle message, minus status.
 415 HELP is `:help' string.
 416 BODY is the function body to use.  If present, it is responsible for
 417 setting the variable and displaying a status message (not MESSAGE)."
 418   (if (< emacs-major-version 21)
 419       `(menu-bar-make-toggle ,name ,variable ,doc ,message ,@body)
 420     `(menu-bar-make-toggle ,name ,variable ,doc ,message ,help ,@body)))
 421
 422 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 423
 424 (provide 'bookmark+-mac)
 425
 426 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 427 ;;; bookmark+-mac.el ends here