lisp/ibuf-macs.el

   1 ;;; ibuf-macs.el --- macros for ibuffer
   2
   3 ;; Copyright (C) 2000-2014 Free Software Foundation, Inc.
   4
   5 ;; Author: Colin Walters <walters@verbum.org>
   6 ;; Maintainer: John Paul Wallington <jpw@gnu.org>
   7 ;; Created: 6 Dec 2001
   8 ;; Keywords: buffer, convenience
   9 ;; Package: ibuffer
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software: you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation, either version 3 of the License, or
  16 ;; (at your option) any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  25
  26 ;;; Commentary:
  27
  28 ;;; Code:
  29
  30 (eval-when-compile (require 'cl-lib))
  31
  32 ;; From Paul Graham's "ANSI Common Lisp", adapted for Emacs Lisp here.
  33 (defmacro ibuffer-aif (test true-body &rest false-body)
  34   "Evaluate TRUE-BODY or FALSE-BODY depending on value of TEST.
  35 If TEST returns non-nil, bind `it' to the value, and evaluate
  36 TRUE-BODY.  Otherwise, evaluate forms in FALSE-BODY as if in `progn'.
  37 Compare with `if'."
  38   (declare (indent 2))
  39   (let ((sym (make-symbol "ibuffer-aif-sym")))
  40     `(let ((,sym ,test))
  41        (if ,sym
  42            (let ((it ,sym))
  43              ,true-body)
  44          (progn
  45            ,@false-body)))))
  46
  47 (defmacro ibuffer-awhen (test &rest body)
  48   "Evaluate BODY if TEST returns non-nil.
  49 During evaluation of body, bind `it' to the value returned by TEST."
  50   (declare (indent 1))
  51   `(ibuffer-aif ,test
  52        (progn ,@body)
  53      nil))
  54
  55 (defmacro ibuffer-save-marks (&rest body)
  56   "Save the marked status of the buffers and execute BODY; restore marks."
  57   (declare (indent 0))
  58   (let ((bufsym (make-symbol "bufsym")))
  59     `(let ((,bufsym (current-buffer))
  60            (ibuffer-save-marks-tmp-mark-list (ibuffer-current-state-list)))
  61        (unwind-protect
  62            (progn
  63              (save-excursion
  64                ,@body))
  65          (with-current-buffer ,bufsym
  66            (ibuffer-redisplay-engine
  67             ;; Get rid of dead buffers
  68             (delq nil
  69                   (mapcar #'(lambda (e) (when (buffer-live-p (car e))
  70                                           e))
  71                           ibuffer-save-marks-tmp-mark-list)))
  72            (ibuffer-redisplay t))))))
  73
  74 ;;;###autoload
  75 (cl-defmacro define-ibuffer-column (symbol (&key name inline props summarizer
  76                                                header-mouse-map) &rest body)
  77   "Define a column SYMBOL for use with `ibuffer-formats'.
  78
  79 BODY will be called with `buffer' bound to the buffer object, and
  80 `mark' bound to the current mark on the buffer.  The original ibuffer
  81 buffer will be bound to `ibuffer-buf'.
  82
  83 If NAME is given, it will be used as a title for the column.
  84 Otherwise, the title will default to a capitalized version of the
  85 SYMBOL's name.  PROPS is a plist of additional properties to add to
  86 the text, such as `mouse-face'.  And SUMMARIZER, if given, is a
  87 function which will be passed a list of all the strings in its column;
  88 it should return a string to display at the bottom.
  89
  90 If HEADER-MOUSE-MAP is given, it will be used as a keymap for the
  91 title of the column.
  92
  93 Note that this macro expands into a `defun' for a function named
  94 ibuffer-make-column-NAME.  If INLINE is non-nil, then the form will be
  95 inlined into the compiled format versions.  This means that if you
  96 change its definition, you should explicitly call
  97 `ibuffer-recompile-formats'.
  98
  99 \(fn SYMBOL (&key NAME INLINE PROPS SUMMARIZER) &rest BODY)"
 100   (declare (indent defun))
 101   (let* ((sym (intern (concat "ibuffer-make-column-"
 102                               (symbol-name symbol))))
 103          (bod-1 `(with-current-buffer buffer
 104                    ,@body))
 105          (bod (if props
 106                   `(propertize
 107                     ,bod-1
 108                     ,@props)
 109                 bod-1)))
 110     `(progn
 111        ,(if inline
 112             `(push '(,sym ,bod) ibuffer-inline-columns)
 113           `(defun ,sym (buffer mark)
 114              ,bod))
 115        (put (quote ,sym) 'ibuffer-column-name
 116             ,(if (stringp name)
 117                  name
 118                (capitalize (symbol-name symbol))))
 119        ,(if header-mouse-map `(put (quote ,sym) 'header-mouse-map ,header-mouse-map))
 120        ,(if summarizer
 121             ;; Store the name of the summarizing function.
 122             `(put (quote ,sym) 'ibuffer-column-summarizer
 123                   (quote ,summarizer)))
 124        ,(if summarizer
 125             ;; This will store the actual values of the column
 126             ;; summary.
 127             `(put (quote ,sym) 'ibuffer-column-summary nil))
 128        :autoload-end)))
 129
 130 ;;;###autoload
 131 (cl-defmacro define-ibuffer-sorter (name documentation
 132                                        (&key
 133                                         description)
 134                                        &rest body)
 135   "Define a method of sorting named NAME.
 136 DOCUMENTATION is the documentation of the function, which will be called
 137 `ibuffer-do-sort-by-NAME'.
 138 DESCRIPTION is a short string describing the sorting method.
 139
 140 For sorting, the forms in BODY will be evaluated with `a' bound to one
 141 buffer object, and `b' bound to another.  BODY should return a non-nil
 142 value if and only if `a' is \"less than\" `b'.
 143
 144 \(fn NAME DOCUMENTATION (&key DESCRIPTION) &rest BODY)"
 145   (declare (indent 1) (doc-string 2))
 146   `(progn
 147      (defun ,(intern (concat "ibuffer-do-sort-by-" (symbol-name name))) ()
 148        ,(or documentation "No :documentation specified for this sorting method.")
 149        (interactive)
 150        (setq ibuffer-sorting-mode ',name)
 151        (when (eq ibuffer-sorting-mode ibuffer-last-sorting-mode)
 152          (setq ibuffer-sorting-reversep (not ibuffer-sorting-reversep)))
 153        (ibuffer-redisplay t)
 154        (setq ibuffer-last-sorting-mode ',name))
 155      (push (list ',name ,description
 156                  #'(lambda (a b)
 157                      ,@body))
 158            ibuffer-sorting-functions-alist)
 159      :autoload-end))
 160
 161 ;;;###autoload
 162 (cl-defmacro define-ibuffer-op (op args
 163                                  documentation
 164                                  (&key
 165                                   interactive
 166                                   mark
 167                                   modifier-p
 168                                   dangerous
 169                                   (opstring "operated on")
 170                                   (active-opstring "Operate on")
 171                                   complex)
 172                                  &rest body)
 173   "Generate a function which operates on a buffer.
 174 OP becomes the name of the function; if it doesn't begin with
 175 `ibuffer-do-', then that is prepended to it.
 176 When an operation is performed, this function will be called once for
 177 each marked buffer, with that buffer current.
 178
 179 ARGS becomes the formal parameters of the function.
 180 DOCUMENTATION becomes the docstring of the function.
 181 INTERACTIVE becomes the interactive specification of the function.
 182 MARK describes which type of mark (:deletion, or nil) this operation
 183 uses.  :deletion means the function operates on buffers marked for
 184 deletion, otherwise it acts on normally marked buffers.
 185 MODIFIER-P describes how the function modifies buffers.  This is used
 186 to set the modification flag of the Ibuffer buffer itself.  Valid
 187 values are:
 188  nil - the function never modifiers buffers
 189  t - the function it always modifies buffers
 190  :maybe - attempt to discover this information by comparing the
 191   buffer's modification flag.
 192 DANGEROUS is a boolean which should be set if the user should be
 193 prompted before performing this operation.
 194 OPSTRING is a string which will be displayed to the user after the
 195 operation is complete, in the form:
 196  \"Operation complete; OPSTRING x buffers\"
 197 ACTIVE-OPSTRING is a string which will be displayed to the user in a
 198 confirmation message, in the form:
 199  \"Really ACTIVE-OPSTRING x buffers?\"
 200 COMPLEX means this function is special; see the source code of this
 201 macro for exactly what it does.
 202
 203 \(fn OP ARGS DOCUMENTATION (&key INTERACTIVE MARK MODIFIER-P DANGEROUS OPSTRING ACTIVE-OPSTRING COMPLEX) &rest BODY)"
 204   (declare (indent 2) (doc-string 3))
 205   `(progn
 206      (defun ,(intern (concat (if (string-match "^ibuffer-do" (symbol-name op))
 207                                  "" "ibuffer-do-") (symbol-name op)))
 208        ,args
 209        ,(if (stringp documentation)
 210             documentation
 211           (format "%s marked buffers." active-opstring))
 212        ,(if (not (null interactive))
 213             `(interactive ,interactive)
 214           '(interactive))
 215        (cl-assert (derived-mode-p 'ibuffer-mode))
 216        (setq ibuffer-did-modification nil)
 217        (let ((marked-names  (,(pcase mark
 218                                 (:deletion
 219                                  'ibuffer-deletion-marked-buffer-names)
 220                                 (_
 221                                  'ibuffer-marked-buffer-names)))))
 222          (when (null marked-names)
 223            (setq marked-names (list (buffer-name (ibuffer-current-buffer))))
 224            (ibuffer-set-mark ,(pcase mark
 225                                 (:deletion
 226                                  'ibuffer-deletion-char)
 227                                 (_
 228                                  'ibuffer-marked-char))))
 229          ,(let* ((finish (append
 230                           '(progn)
 231                           (if (eq modifier-p t)
 232                               '((setq ibuffer-did-modification t))
 233                             ())
 234                           `((ibuffer-redisplay t)
 235                             (message ,(concat "Operation finished; " opstring " %s buffers") count))))
 236                  (inner-body (if complex
 237                                  `(progn ,@body)
 238                                `(progn
 239                                   (with-current-buffer buf
 240                                     (save-excursion
 241                                       ,@body))
 242                                   t)))
 243                  (body `(let ((count
 244                                (,(pcase mark
 245                                    (:deletion
 246                                     'ibuffer-map-deletion-lines)
 247                                    (_
 248                                     'ibuffer-map-marked-lines))
 249                                 #'(lambda (buf mark)
 250                                     ,(if (eq modifier-p :maybe)
 251                                          `(let ((ibuffer-tmp-previous-buffer-modification
 252                                                  (buffer-modified-p buf)))
 253                                             (prog1 ,inner-body
 254                                               (when (not (eq ibuffer-tmp-previous-buffer-modification
 255                                                              (buffer-modified-p buf)))
 256                                                 (setq ibuffer-did-modification t))))
 257                                        inner-body)))))
 258                           ,finish)))
 259             (if dangerous
 260                 `(when (ibuffer-confirm-operation-on ,active-opstring marked-names)
 261                    ,body)
 262               body))))
 263      :autoload-end))
 264
 265 ;;;###autoload
 266 (cl-defmacro define-ibuffer-filter (name documentation
 267                                        (&key
 268                                         reader
 269                                         description)
 270                                        &rest body)
 271   "Define a filter named NAME.
 272 DOCUMENTATION is the documentation of the function.
 273 READER is a form which should read a qualifier from the user.
 274 DESCRIPTION is a short string describing the filter.
 275
 276 BODY should contain forms which will be evaluated to test whether or
 277 not a particular buffer should be displayed or not.  The forms in BODY
 278 will be evaluated with BUF bound to the buffer object, and QUALIFIER
 279 bound to the current value of the filter.
 280
 281 \(fn NAME DOCUMENTATION (&key READER DESCRIPTION) &rest BODY)"
 282   (declare (indent 2) (doc-string 2))
 283   (let ((fn-name (intern (concat "ibuffer-filter-by-" (symbol-name name)))))
 284     `(progn
 285        (defun ,fn-name (qualifier)
 286          ,(or documentation "This filter is not documented.")
 287          (interactive (list ,reader))
 288          (ibuffer-push-filter (cons ',name qualifier))
 289          (message "%s"
 290                   (format ,(concat (format "Filter by %s added: " description)
 291                                    " %s")
 292                           qualifier))
 293          (ibuffer-update nil t))
 294        (push (list ',name ,description
 295                    #'(lambda (buf qualifier)
 296                        ,@body))
 297              ibuffer-filtering-alist)
 298        :autoload-end)))
 299
 300 (provide 'ibuf-macs)
 301
 302 ;;; ibuf-macs.el ends here