ibuf-macs.el 12.8 KB
Newer Older
1
;;; ibuf-macs.el --- macros for ibuffer  -*- lexical-binding:t -*-
Colin Walters's avatar
Colin Walters committed
2

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 2000-2020 Free Software Foundation, Inc.
Colin Walters's avatar
Colin Walters committed
4 5

;; Author: Colin Walters <walters@verbum.org>
6
;; Maintainer: John Paul Wallington <jpw@gnu.org>
Colin Walters's avatar
Colin Walters committed
7 8
;; Created: 6 Dec 2001
;; Keywords: buffer, convenience
9
;; Package: ibuffer
Colin Walters's avatar
Colin Walters committed
10

11
;; This file is part of GNU Emacs.
Colin Walters's avatar
Colin Walters committed
12

13 14 15 16
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Colin Walters's avatar
Colin Walters committed
17

18 19 20 21
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
Colin Walters's avatar
Colin Walters committed
22 23

;; You should have received a copy of the GNU General Public License
24
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
Colin Walters's avatar
Colin Walters committed
25

Pavel Janík's avatar
Pavel Janík committed
26 27
;;; Commentary:

Colin Walters's avatar
Colin Walters committed
28 29
;;; Code:

30
(eval-when-compile (require 'cl-lib))
31

Colin Walters's avatar
Colin Walters committed
32 33 34 35 36 37
;; From Paul Graham's "ANSI Common Lisp", adapted for Emacs Lisp here.
(defmacro ibuffer-aif (test true-body &rest false-body)
  "Evaluate TRUE-BODY or FALSE-BODY depending on value of TEST.
If TEST returns non-nil, bind `it' to the value, and evaluate
TRUE-BODY.  Otherwise, evaluate forms in FALSE-BODY as if in `progn'.
Compare with `if'."
38
  (declare (indent 2))
39
  (let ((sym (make-symbol "ibuffer-aif-sym")))
Colin Walters's avatar
Colin Walters committed
40 41 42 43 44 45 46 47 48 49
    `(let ((,sym ,test))
       (if ,sym
	   (let ((it ,sym))
	     ,true-body)
	 (progn
	   ,@false-body)))))

(defmacro ibuffer-awhen (test &rest body)
  "Evaluate BODY if TEST returns non-nil.
During evaluation of body, bind `it' to the value returned by TEST."
50
  (declare (indent 1))
Colin Walters's avatar
Colin Walters committed
51 52 53 54 55 56
  `(ibuffer-aif ,test
       (progn ,@body)
     nil))

(defmacro ibuffer-save-marks (&rest body)
  "Save the marked status of the buffers and execute BODY; restore marks."
57
  (declare (indent 0))
58
  (let ((bufsym (make-symbol "bufsym")))
Colin Walters's avatar
Colin Walters committed
59 60 61 62 63 64 65
    `(let ((,bufsym (current-buffer))
	   (ibuffer-save-marks-tmp-mark-list (ibuffer-current-state-list)))
       (unwind-protect
	   (progn
	     (save-excursion
	       ,@body))
	 (with-current-buffer ,bufsym
66
	   (ibuffer-redisplay-engine
Colin Walters's avatar
Colin Walters committed
67 68 69 70 71 72 73 74
	    ;; Get rid of dead buffers
	    (delq nil
		  (mapcar #'(lambda (e) (when (buffer-live-p (car e))
					  e))
			  ibuffer-save-marks-tmp-mark-list)))
	   (ibuffer-redisplay t))))))

;;;###autoload
75
(cl-defmacro define-ibuffer-column (symbol (&key name inline props summarizer
76
					       header-mouse-map) &rest body)
Colin Walters's avatar
Colin Walters committed
77 78 79
  "Define a column SYMBOL for use with `ibuffer-formats'.

BODY will be called with `buffer' bound to the buffer object, and
80 81
`mark' bound to the current mark on the buffer.  The original ibuffer
buffer will be bound to `ibuffer-buf'.
Colin Walters's avatar
Colin Walters committed
82 83 84 85

If NAME is given, it will be used as a title for the column.
Otherwise, the title will default to a capitalized version of the
SYMBOL's name.  PROPS is a plist of additional properties to add to
86 87 88
the text, such as `mouse-face'.  And SUMMARIZER, if given, is a
function which will be passed a list of all the strings in its column;
it should return a string to display at the bottom.
Colin Walters's avatar
Colin Walters committed
89

90 91 92
If HEADER-MOUSE-MAP is given, it will be used as a keymap for the
title of the column.

Colin Walters's avatar
Colin Walters committed
93 94 95 96
Note that this macro expands into a `defun' for a function named
ibuffer-make-column-NAME.  If INLINE is non-nil, then the form will be
inlined into the compiled format versions.  This means that if you
change its definition, you should explicitly call
97 98 99
`ibuffer-recompile-formats'.

\(fn SYMBOL (&key NAME INLINE PROPS SUMMARIZER) &rest BODY)"
100
  (declare (indent defun))
Colin Walters's avatar
Colin Walters committed
101 102
  (let* ((sym (intern (concat "ibuffer-make-column-"
			      (symbol-name symbol))))
103
	 (bod-1 `(with-current-buffer buffer
Colin Walters's avatar
Colin Walters committed
104 105
		   ,@body))
	 (bod (if props
106 107 108
		  `(propertize
		    ,bod-1
		    ,@props)
Colin Walters's avatar
Colin Walters committed
109 110 111 112
		bod-1)))
    `(progn
       ,(if inline
	    `(push '(,sym ,bod) ibuffer-inline-columns)
113
	  `(defun ,sym (buffer mark)
114
             (ignore mark)            ;Silence byte-compiler if mark is unused.
Colin Walters's avatar
Colin Walters committed
115 116 117 118 119
	     ,bod))
       (put (quote ,sym) 'ibuffer-column-name
	    ,(if (stringp name)
		 name
	       (capitalize (symbol-name symbol))))
120
       ,(if header-mouse-map `(put (quote ,sym) 'header-mouse-map ,header-mouse-map))
121
       ,(if summarizer
122
	    ;; Store the name of the summarizing function.
123 124 125
	    `(put (quote ,sym) 'ibuffer-column-summarizer
		  (quote ,summarizer)))
       ,(if summarizer
126 127 128
	    ;; This will store the actual values of the column
	    ;; summary.
	    `(put (quote ,sym) 'ibuffer-column-summary nil))
Colin Walters's avatar
Colin Walters committed
129 130 131
       :autoload-end)))

;;;###autoload
132
(cl-defmacro define-ibuffer-sorter (name documentation
133
				       (&key
Colin Walters's avatar
Colin Walters committed
134 135 136 137 138 139 140 141 142
					description)
				       &rest body)
  "Define a method of sorting named NAME.
DOCUMENTATION is the documentation of the function, which will be called
`ibuffer-do-sort-by-NAME'.
DESCRIPTION is a short string describing the sorting method.

For sorting, the forms in BODY will be evaluated with `a' bound to one
buffer object, and `b' bound to another.  BODY should return a non-nil
143 144 145
value if and only if `a' is \"less than\" `b'.

\(fn NAME DOCUMENTATION (&key DESCRIPTION) &rest BODY)"
146
  (declare (indent 1) (doc-string 2))
Colin Walters's avatar
Colin Walters committed
147 148 149 150 151
  `(progn
     (defun ,(intern (concat "ibuffer-do-sort-by-" (symbol-name name))) ()
       ,(or documentation "No :documentation specified for this sorting method.")
       (interactive)
       (setq ibuffer-sorting-mode ',name)
152 153 154 155
       (when (eq ibuffer-sorting-mode ibuffer-last-sorting-mode)
	 (setq ibuffer-sorting-reversep (not ibuffer-sorting-reversep)))
       (ibuffer-redisplay t)
       (setq ibuffer-last-sorting-mode ',name))
Colin Walters's avatar
Colin Walters committed
156 157 158 159 160 161 162
     (push (list ',name ,description
		 #'(lambda (a b)
		     ,@body))
	   ibuffer-sorting-functions-alist)
     :autoload-end))

;;;###autoload
163
(cl-defmacro define-ibuffer-op (op args
Colin Walters's avatar
Colin Walters committed
164
				 documentation
165
				 (&key
Colin Walters's avatar
Colin Walters committed
166 167 168 169 170 171
				  interactive
				  mark
				  modifier-p
				  dangerous
				  (opstring "operated on")
				  (active-opstring "Operate on")
172 173
                                  before
                                  after
Colin Walters's avatar
Colin Walters committed
174 175
				  complex)
				 &rest body)
176 177 178
  "Generate a function which operates on a buffer.
OP becomes the name of the function; if it doesn't begin with
`ibuffer-do-', then that is prepended to it.
Colin Walters's avatar
Colin Walters committed
179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202
When an operation is performed, this function will be called once for
each marked buffer, with that buffer current.

ARGS becomes the formal parameters of the function.
DOCUMENTATION becomes the docstring of the function.
INTERACTIVE becomes the interactive specification of the function.
MARK describes which type of mark (:deletion, or nil) this operation
uses.  :deletion means the function operates on buffers marked for
deletion, otherwise it acts on normally marked buffers.
MODIFIER-P describes how the function modifies buffers.  This is used
to set the modification flag of the Ibuffer buffer itself.  Valid
values are:
 nil - the function never modifiers buffers
 t - the function it always modifies buffers
 :maybe - attempt to discover this information by comparing the
  buffer's modification flag.
DANGEROUS is a boolean which should be set if the user should be
prompted before performing this operation.
OPSTRING is a string which will be displayed to the user after the
operation is complete, in the form:
 \"Operation complete; OPSTRING x buffers\"
ACTIVE-OPSTRING is a string which will be displayed to the user in a
confirmation message, in the form:
 \"Really ACTIVE-OPSTRING x buffers?\"
203 204
BEFORE is a form to evaluate before start the operation.
AFTER is a form to evaluate once the operation is complete.
205 206 207 208 209
COMPLEX means this function is special; if COMPLEX is nil BODY
evaluates once for each marked buffer, MBUF, with MBUF current
and saving the point.  If COMPLEX is non-nil, BODY evaluates
without requiring MBUF current.
BODY define the operation; they are forms to evaluate per each
210 211
marked buffer.  BODY is evaluated with `buf' bound to the
buffer object.
212

213
\(fn OP ARGS DOCUMENTATION (&key INTERACTIVE MARK MODIFIER-P DANGEROUS OPSTRING ACTIVE-OPSTRING BEFORE AFTER COMPLEX) &rest BODY)"
214
  (declare (indent 2) (doc-string 3))
Colin Walters's avatar
Colin Walters committed
215
  `(progn
216
     (defun ,(intern (concat (if (string-match "^ibuffer-do" (symbol-name op))
217 218
				 "" "ibuffer-do-")
                             (symbol-name op)))
219 220 221 222 223 224 225
       ,args
       ,(if (stringp documentation)
	    documentation
	  (format "%s marked buffers." active-opstring))
       ,(if (not (null interactive))
	    `(interactive ,interactive)
	  '(interactive))
226
       (cl-assert (derived-mode-p 'ibuffer-mode))
227
       (setq ibuffer-did-modification nil)
228
       (let ((marked-names  (,(pcase mark
229 230
				(:deletion
				 'ibuffer-deletion-marked-buffer-names)
231
				(_
232 233 234
				 'ibuffer-marked-buffer-names)))))
	 (when (null marked-names)
	   (setq marked-names (list (buffer-name (ibuffer-current-buffer))))
235
	   (ibuffer-set-mark ,(pcase mark
236 237
				(:deletion
				 'ibuffer-deletion-char)
238
				(_
239 240 241 242 243 244
				 'ibuffer-marked-char))))
	 ,(let* ((finish (append
			  '(progn)
			  (if (eq modifier-p t)
			      '((setq ibuffer-did-modification t))
			    ())
245
                          (and after `(,after)) ; post-operation form.
246 247 248 249 250 251 252 253 254
			  `((ibuffer-redisplay t)
			    (message ,(concat "Operation finished; " opstring " %s buffers") count))))
		 (inner-body (if complex
				 `(progn ,@body)
			       `(progn
				  (with-current-buffer buf
				    (save-excursion
				      ,@body))
				  t)))
255 256
		 (body `(let ((_ ,before) ; pre-operation form.
                               (count
257
			       (,(pcase mark
258 259
				   (:deletion
				    'ibuffer-map-deletion-lines)
260
				   (_
261 262
				    'ibuffer-map-marked-lines))
				#'(lambda (buf mark)
263 264 265
                                    ;; Silence warning for code that doesn't
                                    ;; use `mark'.
                                    (ignore mark)
266 267 268 269 270 271 272 273 274 275 276 277 278 279
				    ,(if (eq modifier-p :maybe)
					 `(let ((ibuffer-tmp-previous-buffer-modification
						 (buffer-modified-p buf)))
					    (prog1 ,inner-body
					      (when (not (eq ibuffer-tmp-previous-buffer-modification
							     (buffer-modified-p buf)))
						(setq ibuffer-did-modification t))))
				       inner-body)))))
			  ,finish)))
	    (if dangerous
		`(when (ibuffer-confirm-operation-on ,active-opstring marked-names)
		   ,body)
	      body))))
     :autoload-end))
Colin Walters's avatar
Colin Walters committed
280 281

;;;###autoload
282
(cl-defmacro define-ibuffer-filter (name documentation
283 284 285 286 287
                                         (&key
                                          reader
                                          description
                                          accept-list)
                                         &rest body)
Colin Walters's avatar
Colin Walters committed
288 289 290 291
  "Define a filter named NAME.
DOCUMENTATION is the documentation of the function.
READER is a form which should read a qualifier from the user.
DESCRIPTION is a short string describing the filter.
292 293 294
ACCEPT-LIST is a boolean; if non-nil, the filter accepts either
a single condition or a list of them; in the latter
case the filter is the `or' composition of the conditions.
Colin Walters's avatar
Colin Walters committed
295 296 297 298

BODY should contain forms which will be evaluated to test whether or
not a particular buffer should be displayed or not.  The forms in BODY
will be evaluated with BUF bound to the buffer object, and QUALIFIER
299 300 301
bound to the current value of the filter.

\(fn NAME DOCUMENTATION (&key READER DESCRIPTION) &rest BODY)"
302
  (declare (indent 2) (doc-string 2))
303 304 305
  (let ((fn-name (intern (concat "ibuffer-filter-by-" (symbol-name name))))
        (filter (make-symbol "ibuffer-filter"))
        (qualifier-str (make-symbol "ibuffer-qualifier-str")))
306
    `(progn
Colin Walters's avatar
Colin Walters committed
307
       (defun ,fn-name (qualifier)
308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328
     ,(or documentation "This filter is not documented.")
     (interactive (list ,reader))
     (let ((,filter (cons ',name qualifier))
           (,qualifier-str qualifier))
       ,(when accept-list
          `(progn
         (unless (listp qualifier) (setq qualifier (list qualifier)))
         ;; Reject equivalent filters: (or f1 f2) is same as (or f2 f1).
         (setq qualifier (sort (delete-dups qualifier) #'string-lessp))
         (setq ,filter (cons ',name (car qualifier)))
         (setq ,qualifier-str
               (mapconcat (lambda (m) (if (symbolp m) (symbol-name m) m))
                  qualifier ","))
         (when (cdr qualifier) ; Compose individual filters with `or'.
           (setq ,filter `(or ,@(mapcar (lambda (m) (cons ',name m)) qualifier))))))
       (if (null (ibuffer-push-filter ,filter))
           (message ,(format "Filter by %s already applied:  %%s" description)
                ,qualifier-str)
         (message ,(format "Filter by %s added:  %%s" description)
              ,qualifier-str)
         (ibuffer-update nil t))))
Colin Walters's avatar
Colin Walters committed
329
       (push (list ',name ,description
330 331 332 333 334 335 336 337
           (lambda (buf qualifier)
                  (condition-case nil
                      (progn ,@body)
                    (error (ibuffer-pop-filter)
                           (when (eq ',name 'predicate)
                             (error "Wrong filter predicate: %S"
                                    qualifier))))))
         ibuffer-filtering-alist)
Colin Walters's avatar
Colin Walters committed
338 339 340 341 342
       :autoload-end)))

(provide 'ibuf-macs)

;;; ibuf-macs.el ends here