cgit.sxemacs.org Git - packages/blob - xemacs-packages/ibuffer/ibuf-ext.el

   1 ;;; ibuf-ext.el --- extensions for ibuffer -*-byte-compile-dynamic: t;-*-
   2
   3 ;; Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc.
   4
   5 ;; Author: Colin Walters <walters@verbum.org>
   6 ;; Created: 2 Dec 2001
   7 ;; Keywords: buffer, convenience
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; This program is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program ; see the file COPYING.  If not, write to
  23 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; These functions should be automatically loaded when called, but you
  29 ;; can explicity (require 'ibuf-ext) in your ~/.emacs to have them
  30 ;; preloaded.
  31
  32 ;;; Code:
  33
  34 (require 'ibuffer)
  35
  36 (eval-when-compile
  37   (require 'derived)
  38   (require 'ibuf-macs)
  39   (require 'cl))
  40
  41 ;;; Utility functions
  42 (defun ibuffer-delete-alist (key alist)
  43   "Delete all entries in ALIST that have a key equal to KEY."
  44   (let (entry)
  45     (while (setq entry (assoc key alist))
  46       (setq alist (delete entry alist)))
  47     alist))
  48
  49 (defun ibuffer-depropertize-string (str &optional nocopy)
  50   "Return a copy of STR with text properties removed.
  51 If optional argument NOCOPY is non-nil, actually modify the string directly."
  52   (let ((str (if nocopy
  53                  str
  54                (copy-sequence str))))
  55     (set-text-properties 0 (length str) nil str)
  56     str))
  57
  58 (defun ibuffer-split-list (ibuffer-split-list-fn ibuffer-split-list-elts)
  59   (let ((hip-crowd nil)
  60         (lamers nil))
  61     (dolist (ibuffer-split-list-elt ibuffer-split-list-elts)
  62       (if (funcall ibuffer-split-list-fn ibuffer-split-list-elt)
  63           (push ibuffer-split-list-elt hip-crowd)
  64         (push ibuffer-split-list-elt lamers)))
  65     ;; Too bad Emacs Lisp doesn't have multiple values.
  66     (list (nreverse hip-crowd) (nreverse lamers))))
  67
  68 (defvar ibuffer-tmp-hide-regexps nil
  69   "A list of regexps which should match buffer names to not show.")
  70
  71 (defvar ibuffer-tmp-show-regexps nil
  72   "A list of regexps which should match buffer names to always show.")
  73
  74 (defvar ibuffer-auto-mode nil
  75   "If non-nil, Ibuffer auto-mode should be enabled for this buffer.
  76 Do not set this variable directly!  Use the function
  77 `ibuffer-auto-mode' instead.")
  78
  79 (defvar ibuffer-auto-buffers-changed nil)
  80
  81 (defvar ibuffer-filtering-qualifiers nil
  82   "A list like (SYMBOL . QUALIFIER) which filters the current buffer list.
  83 See also `ibuffer-filtering-alist'.")
  84
  85 ;; This is now frobbed by `define-ibuffer-filter'.
  86 (defvar ibuffer-filtering-alist nil
  87   "An alist of (SYMBOL DESCRIPTION FUNCTION) which describes a filter.
  88
  89 You most likely do not want to modify this variable directly; see
  90 `define-ibuffer-filter'.
  91
  92 SYMBOL is the symbolic name of the filter.  DESCRIPTION is used when
  93 displaying information to the user.  FUNCTION is given a buffer and
  94 the value of the qualifier, and returns non-nil if and only if the
  95 buffer should be displayed.")
  96
  97 (defvar ibuffer-cached-filter-formats nil)
  98 (defvar ibuffer-compiled-filter-formats nil)
  99
 100 (defvar ibuffer-filter-groups nil
 101   "A list like ((\"NAME\" ((SYMBOL . QUALIFIER) ...) ...) which groups buffers.
 102 The SYMBOL should be one from `ibuffer-filtering-alist'.
 103 The QUALIFIER should be the same as QUALIFIER in
 104 `ibuffer-filtering-qualifiers'.")
 105
 106 (defcustom ibuffer-show-empty-filter-groups t
 107   "If non-nil, then show the names of filter groups which are empty."
 108   :type 'boolean
 109   :group 'ibuffer)
 110
 111 (defcustom ibuffer-saved-filter-groups
 112   '(("gnus"
 113      ((or (mode . message-mode)
 114           (mode . mail-mode)
 115           (mode . gnus-group-mode)
 116           (mode . gnus-summary-mode)
 117           (mode . gnus-article-mode))))
 118     ("programming"
 119      ((or (mode . emacs-lisp-mode)
 120           (mode . cperl-mode)
 121           (mode . c-mode)
 122           (mode . java-mode)
 123           (mode . idl-mode)
 124           (mode . lisp-mode)))))
 125
 126   "An alist of filtering groups to switch between.
 127
 128 This variable should look like ((\"STRING\" QUALIFIERS)
 129                                 (\"STRING\" QUALIFIERS) ...), where
 130 QUALIFIERS is a list of the same form as
 131 `ibuffer-filtering-qualifiers'.
 132
 133 See also the variables `ibuffer-filter-groups',
 134 `ibuffer-filtering-qualifiers', `ibuffer-filtering-alist', and the
 135 functions `ibuffer-switch-to-saved-filter-group',
 136 `ibuffer-save-filter-group'."
 137   :type '(repeat sexp)
 138   :group 'ibuffer)
 139
 140 (defvar ibuffer-hidden-filter-groups nil
 141   "A list of filtering groups which are currently hidden.")
 142
 143 (defvar ibuffer-filter-group-kill-ring nil)
 144
 145 (defun ibuffer-ext-visible-p (buf all &optional ibuffer-buf)
 146   (or
 147    (ibuffer-buf-matches-predicates buf ibuffer-tmp-show-regexps)
 148    (and (not
 149          (or
 150           (ibuffer-buf-matches-predicates buf ibuffer-tmp-hide-regexps)
 151           (ibuffer-buf-matches-predicates buf ibuffer-never-show-predicates)))
 152         (or all
 153             (not
 154              (ibuffer-buf-matches-predicates buf ibuffer-maybe-show-predicates)))
 155         (or ibuffer-view-ibuffer
 156             (and ibuffer-buf
 157                  (not (eq ibuffer-buf buf))))
 158         (or
 159          (ibuffer-included-in-filters-p buf ibuffer-filtering-qualifiers)
 160          (ibuffer-buf-matches-predicates buf ibuffer-always-show-predicates)))))
 161
 162 (defun ibuffer-auto-update-changed ()
 163   (when ibuffer-auto-buffers-changed
 164     (setq ibuffer-auto-buffers-changed nil)
 165     (mapcar #'(lambda (buf)
 166                 (ignore-errors
 167                   (with-current-buffer buf
 168                     (when (and ibuffer-auto-mode
 169                                (eq major-mode 'ibuffer-mode))
 170                       (ibuffer-update nil t)))))
 171             (buffer-list))))
 172
 173 ;;;###autoload
 174 (defun ibuffer-auto-mode (&optional arg)
 175   "Toggle use of Ibuffer's auto-update facility.
 176 With numeric ARG, enable auto-update if and only if ARG is positive."
 177   (interactive)
 178   (unless (eq major-mode 'ibuffer-mode)
 179     (error "This buffer is not in Ibuffer mode"))
 180   (set (make-local-variable 'ibuffer-auto-mode)
 181        (if arg
 182            (plusp arg)
 183          (not ibuffer-auto-mode)))
 184   (defadvice get-buffer-create (after ibuffer-notify-create activate)
 185     (setq ibuffer-auto-buffers-changed t))
 186   (defadvice kill-buffer (after ibuffer-notify-kill activate)
 187     (setq ibuffer-auto-buffers-changed t))
 188   (add-hook 'post-command-hook 'ibuffer-auto-update-changed)
 189   (ibuffer-update-mode-name))
 190
 191 (defun ibuffer-mouse-filter-by-mode (event)
 192   "Enable or disable filtering by the major mode chosen via mouse."
 193   (interactive "e")
 194   (ibuffer-interactive-filter-by-mode event))
 195
 196 (defun ibuffer-interactive-filter-by-mode (event-or-point)
 197   "Enable or disable filtering by the major mode at point."
 198   (interactive "d")
 199   (if (eventp event-or-point)
 200       (mouse-set-point event-or-point)
 201     (goto-char event-or-point))
 202   (let ((buf (ibuffer-current-buffer)))
 203     (if (assq 'mode ibuffer-filtering-qualifiers)
 204         (setq ibuffer-filtering-qualifiers
 205               (ibuffer-delete-alist 'mode ibuffer-filtering-qualifiers))
 206       (ibuffer-push-filter (cons 'mode
 207                                 (with-current-buffer buf
 208                                   major-mode)))))
 209   (ibuffer-update nil t))
 210
 211 (defun ibuffer-mouse-toggle-filter-group (event)
 212   "Toggle the display status of the filter group chosen with the mouse."
 213   (interactive "e")
 214   (ibuffer-toggle-filter-group-1 (save-excursion
 215                                    (mouse-set-point event)
 216                                    (point))))
 217
 218 (defun ibuffer-toggle-filter-group ()
 219   "Toggle the display status of the filter group on this line."
 220   (interactive)
 221   (ibuffer-toggle-filter-group-1 (point)))
 222
 223 (defun ibuffer-toggle-filter-group-1 (posn)
 224   (let ((name (get-text-property posn 'ibuffer-filter-group-name)))
 225     (unless (stringp name)
 226       (error "No filtering group name present"))
 227     (if (member name ibuffer-hidden-filter-groups)
 228         (setq ibuffer-hidden-filter-groups
 229               (delete name ibuffer-hidden-filter-groups))
 230       (push name ibuffer-hidden-filter-groups))
 231     (ibuffer-update nil t)))
 232
 233 (defun ibuffer-forward-filter-group (&optional count)
 234   "Move point forwards by COUNT filtering groups."
 235   (interactive "P")
 236   (unless count
 237     (setq count 1))
 238   (when (> count 0)
 239     (when (get-text-property (point) 'ibuffer-filter-group-name)
 240       (goto-char (next-single-property-change
 241                   (point) 'ibuffer-filter-group-name
 242                   nil (point-max))))
 243     (goto-char (next-single-property-change
 244                 (point) 'ibuffer-filter-group-name
 245                 nil (point-max)))
 246     (ibuffer-forward-filter-group (1- count)))
 247   (ibuffer-forward-line 0))
 248
 249 ;;;###autoload
 250 (defun ibuffer-backward-filter-group (&optional count)
 251   "Move point backwards by COUNT filtering groups."
 252   (interactive "P")
 253   (unless count
 254     (setq count 1))
 255   (when (> count 0)
 256     (when (get-text-property (point) 'ibuffer-filter-group-name)
 257       (goto-char (previous-single-property-change
 258                   (point) 'ibuffer-filter-group-name
 259                   nil (point-min))))
 260     (goto-char (previous-single-property-change
 261                 (point) 'ibuffer-filter-group-name
 262                 nil (point-min)))
 263     (ibuffer-backward-filter-group (1- count)))
 264   (when (= (point) (point-min))
 265     (goto-char (point-max))
 266     (ibuffer-backward-filter-group 1))
 267   (ibuffer-forward-line 0))
 268
 269 (define-ibuffer-op shell-command-pipe (command)
 270   "Pipe the contents of each marked buffer to shell command COMMAND."
 271   (:interactive "sPipe to shell command: "
 272    :opstring "Shell command executed on"
 273    :modifier-p nil)
 274   (shell-command-on-region
 275    (point-min) (point-max) command
 276    (get-buffer-create "* ibuffer-shell-output*")))
 277
 278 (define-ibuffer-op shell-command-pipe-replace (command)
 279   "Replace the contents of marked buffers with output of pipe to COMMAND."
 280   (:interactive "sPipe to shell command (replace): "
 281    :opstring "Buffer contents replaced in"
 282    :active-opstring "replace buffer contents in"
 283    :dangerous t
 284    :modifier-p t)
 285   (with-current-buffer buf
 286     (shell-command-on-region (point-min) (point-max)
 287                              command nil t)))
 288
 289 (define-ibuffer-op shell-command-file (command)
 290   "Run shell command COMMAND separately on files of marked buffers."
 291   (:interactive "sShell command on buffer's file: "
 292    :opstring "Shell command executed on"
 293    :modifier-p nil)
 294   (shell-command (concat command " "
 295                          (shell-quote-argument
 296                           (if buffer-file-name
 297                               buffer-file-name
 298                             (ibuffer-make-temp-file
 299                              (substring (buffer-name) 0 (min 10 (length (buffer-name))))))))))
 300
 301 (define-ibuffer-op eval (form)
 302   "Evaluate FORM in each of the buffers.
 303 Does not display the buffer during evaluation. See
 304 `ibuffer-do-view-and-eval' for that."
 305   (:interactive "xEval in buffers (form): "
 306    :opstring "evaluated in"
 307    :modifier-p :maybe)
 308   (eval form))
 309
 310 (define-ibuffer-op view-and-eval (form)
 311   "Evaluate FORM while displaying each of the marked buffers.
 312 To evaluate a form without viewing the buffer, see `ibuffer-do-eval'."
 313   (:interactive "xEval viewing buffers (form): "
 314    :opstring "evaluated in"
 315    :complex t
 316    :modifier-p :maybe)
 317   (let ((ibuffer-buf (current-buffer)))
 318     (unwind-protect
 319         (progn
 320           (switch-to-buffer buf)
 321           (eval form))
 322       (switch-to-buffer ibuffer-buf))))
 323
 324 (define-ibuffer-op rename-uniquely ()
 325   "Rename marked buffers as with `rename-uniquely'."
 326   (:opstring "renamed"
 327    :modifier-p t)
 328   (rename-uniquely))
 329
 330 (define-ibuffer-op revert ()
 331   "Revert marked buffers as with `revert-buffer'."
 332   (:dangerous t
 333    :opstring "reverted"
 334    :active-opstring "revert"
 335    :modifier-p :maybe)
 336   (revert-buffer t t))
 337
 338 (define-ibuffer-op replace-regexp (from-str to-str)
 339   "Perform a `replace-regexp' in marked buffers."
 340   (:interactive
 341    (let* ((from-str (read-from-minibuffer "Replace regexp: "))
 342           (to-str (read-from-minibuffer (concat "Replace " from-str
 343                                                 " with: "))))
 344      (list from-str to-str))
 345    :opstring "replaced in"
 346    :complex t
 347    :modifier-p :maybe)
 348   (save-window-excursion
 349     (switch-to-buffer buf)
 350     (save-excursion
 351       (goto-char (point-min))
 352       (let ((case-fold-search ibuffer-case-fold-search))
 353         (while (re-search-forward from-str nil t)
 354           (replace-match to-str))))
 355     t))
 356
 357 (define-ibuffer-op query-replace (&rest args)
 358   "Perform a `query-replace' in marked buffers."
 359   (:interactive
 360    (query-replace-read-args "Query replace" t)
 361    :opstring "replaced in"
 362    :complex t
 363    :modifier-p :maybe)
 364   (save-window-excursion
 365     (switch-to-buffer buf)
 366     (save-excursion
 367       (let ((case-fold-search ibuffer-case-fold-search))
 368         (goto-char (point-min))
 369         (apply #'query-replace args)))
 370     t))
 371
 372 (define-ibuffer-op query-replace-regexp (&rest args)
 373   "Perform a `query-replace-regexp' in marked buffers."
 374   (:interactive
 375    (query-replace-read-args "Query replace regexp" t)
 376    :opstring "replaced in"
 377    :complex t
 378    :modifier-p :maybe)
 379   (save-window-excursion
 380     (switch-to-buffer buf)
 381     (save-excursion
 382       (let ((case-fold-search ibuffer-case-fold-search))
 383         (goto-char (point-min))
 384         (apply #'query-replace-regexp args)))
 385     t))
 386
 387 (define-ibuffer-op print ()
 388   "Print marked buffers as with `print-buffer'."
 389   (:opstring "printed"
 390    :modifier-p nil)
 391   (print-buffer))
 392
 393 ;;;###autoload
 394 (defun ibuffer-included-in-filters-p (buf filters)
 395   (not
 396    (memq nil ;; a filter will return nil if it failed
 397          (mapcar
 398           ;; filter should be like (TYPE . QUALIFIER), or
 399           ;; (or (TYPE . QUALIFIER) (TYPE . QUALIFIER) ...)
 400           #'(lambda (qual)
 401               (ibuffer-included-in-filter-p buf qual))
 402           filters))))
 403
 404 (defun ibuffer-included-in-filter-p (buf filter)
 405   (if (eq (car filter) 'not)
 406       (not (ibuffer-included-in-filter-p-1 buf (cdr filter)))
 407     (ibuffer-included-in-filter-p-1 buf filter)))
 408
 409 (defun ibuffer-included-in-filter-p-1 (buf filter)
 410   (not
 411    (not
 412     (case (car filter)
 413       (or
 414        (memq t (mapcar #'(lambda (x)
 415                            (ibuffer-included-in-filter-p buf x))
 416                        (cdr filter))))
 417       (saved
 418        (let ((data
 419               (assoc (cdr filter)
 420                      ibuffer-saved-filters)))
 421          (unless data
 422            (ibuffer-filter-disable)
 423            (error "Unknown saved filter %s" (cdr filter)))
 424          (ibuffer-included-in-filters-p buf (cadr data))))
 425       (t
 426        (let ((filterdat (assq (car filter)
 427                               ibuffer-filtering-alist)))
 428          ;; filterdat should be like (TYPE DESCRIPTION FUNC)
 429          ;; just a sanity check
 430         (unless filterdat
 431           (ibuffer-filter-disable)
 432           (error "Undefined filter %s" (car filter)))
 433         (not
 434          (not
 435           (funcall (caddr filterdat)
 436                    buf
 437                    (cdr filter))))))))))
 438
 439 (defun ibuffer-generate-filter-groups (bmarklist)
 440   (let ((filter-group-alist (append ibuffer-filter-groups
 441                                        (list (cons "Default" nil)))))
 442 ;;     (dolist (hidden ibuffer-hidden-filter-groups)
 443 ;;       (setq filter-group-alist (ibuffer-delete-alist
 444 ;;                                 hidden filter-group-alist)))
 445     (let ((vec (make-vector (length filter-group-alist) nil))
 446           (i 0))
 447       (dolist (filtergroup filter-group-alist)
 448         (let ((filterset (cdr filtergroup)))
 449           (destructuring-bind (hip-crowd lamers)
 450               (ibuffer-split-list (lambda (bufmark)
 451                                     (ibuffer-included-in-filters-p (car bufmark)
 452                                                                    filterset))
 453                                   bmarklist)
 454             (aset vec i hip-crowd)
 455             (incf i)
 456             (setq bmarklist lamers))))
 457       (let ((ret nil))
 458         (dotimes (j i ret)
 459           (push (cons (car (nth j filter-group-alist))
 460                       (aref vec j))
 461                 ret))))))
 462
 463 ;;;###autoload
 464 (defun ibuffer-filters-to-filter-group (name)
 465   "Make the current filters into a filtering group."
 466   (interactive "sName for filtering group: ")
 467   (when (null ibuffer-filtering-qualifiers)
 468     (error "No filters in effect"))
 469   (push (cons name ibuffer-filtering-qualifiers) ibuffer-filter-groups)
 470   (ibuffer-filter-disable))
 471
 472 ;;;###autoload
 473 (defun ibuffer-set-filter-groups-by-mode ()
 474   "Set the current filter groups to filter by mode."
 475   (interactive)
 476   (setq ibuffer-filter-groups
 477         (mapcar (lambda (mode)
 478                   (cons (format "%s" mode) `((mode . ,mode))))
 479                 (let ((modes
 480                        (delete-duplicates
 481                         (mapcar (lambda (buf) (with-current-buffer buf major-mode))
 482                                 (buffer-list)))))
 483                   (unless ibuffer-view-ibuffer
 484                     (setq modes (delq 'ibuffer-mode modes)))
 485                   modes)))
 486   (ibuffer-update nil t))
 487
 488 ;;;###autoload
 489 (defun ibuffer-pop-filter-group ()
 490   "Remove the first filtering group."
 491   (interactive)
 492   (when (null ibuffer-filter-groups)
 493     (error "No filtering groups active"))
 494   (pop ibuffer-filter-groups)
 495   (ibuffer-update nil t))
 496
 497 ;;;###autoload
 498 (defun ibuffer-clear-filter-groups ()
 499   "Remove all filtering groups."
 500   (interactive)
 501   (setq ibuffer-filter-groups nil)
 502   (ibuffer-update nil t))
 503
 504 (defun ibuffer-current-filter-groups-with-position ()
 505   (save-excursion
 506     (goto-char (point-min))
 507     (let ((pos nil)
 508           (result nil))
 509       (while (and (not (eobp))
 510                   (setq pos (next-single-property-change
 511                              (point) 'ibuffer-filter-group-name)))
 512         (goto-char pos)
 513         (push (cons (get-text-property (point) 'ibuffer-filter-group-name)
 514                     pos)
 515               result)
 516         (goto-char (next-single-property-change
 517                     pos 'ibuffer-filter-group-name)))
 518       (nreverse result))))
 519
 520 ;;;###autoload
 521 (defun ibuffer-jump-to-filter-group (name)
 522   "Move point to the filter group whose name is NAME."
 523   (interactive (list nil))
 524   (let ((table (ibuffer-current-filter-groups-with-position)))
 525     (when (interactive-p)
 526       (setq name (completing-read "Jump to filter group: " table nil t)))
 527     (ibuffer-aif (assoc name table)
 528         (goto-char (cdr it))
 529       (error "No filter group with name %s" name))))
 530
 531 ;;;###autoload
 532 (defun ibuffer-kill-filter-group (name)
 533   "Delete the filtering group named NAME."
 534   (interactive (list nil))
 535   (when (interactive-p)
 536     (setq name (completing-read "Kill filter group: "
 537                                 ibuffer-filter-groups nil t)))
 538   (ibuffer-aif (assoc name ibuffer-filter-groups)
 539       (setq ibuffer-filter-groups (ibuffer-delete-alist
 540                                    name ibuffer-filter-groups))
 541     (error "No filter group with name \"%s\"" name))
 542   (ibuffer-update nil t))
 543
 544 ;;;###autoload
 545 (defun ibuffer-kill-line (&optional arg)
 546   (interactive "P")
 547   (ibuffer-aif (save-excursion
 548                  (ibuffer-forward-line 0)
 549                  (get-text-property (point) 'ibuffer-filter-group-name))
 550       (progn
 551         (when (equal it "Default")
 552           (error "Can't kill default filtering group"))
 553         (push (copy-tree (assoc it ibuffer-filter-groups))
 554               ibuffer-filter-group-kill-ring)
 555         (ibuffer-kill-filter-group it))
 556       (funcall (if (interactive-p) #'call-interactively #'funcall)
 557                #'kill-line arg)))
 558
 559 ;;;###autoload
 560 (defun ibuffer-yank (&optional arg)
 561   (interactive "P")
 562   (unless ibuffer-filter-group-kill-ring
 563     (error "ibuffer-filter-group-kill-ring is empty"))
 564   (save-excursion
 565     (ibuffer-forward-line 0)
 566     (let* ((last-killed (pop ibuffer-filter-group-kill-ring))
 567            (all-groups ibuffer-filter-groups)
 568            (cur (or (get-text-property (point) 'ibuffer-filter-group-name)
 569                     (get-text-property (point) 'ibuffer-filter-group)
 570                     (last all-groups)))
 571            (pos (or (position cur (mapcar #'car all-groups) :test #'equal)
 572                     (length all-groups))))
 573       (cond ((= pos 0)
 574              (push last-killed ibuffer-filter-groups))
 575             ((= pos (length all-groups))
 576              (setq ibuffer-filter-groups
 577                    (nconc ibuffer-filter-groups (list last-killed))))
 578             (t
 579              (let ((cell (nthcdr pos ibuffer-filter-groups)))
 580                (setf (cdr cell) (cons (car cell) (cdr cell)))
 581                (setf (car cell) last-killed))))))
 582   (ibuffer-update nil t))
 583
 584 ;;;###autoload
 585 (defun ibuffer-save-filter-groups (name groups)
 586   "Save all active filter groups GROUPS as NAME.
 587 They are added to `ibuffer-saved-filter-groups'.  Interactively,
 588 prompt for NAME, and use the current filters."
 589   (interactive
 590    (if (null ibuffer-filter-groups)
 591        (error "No filter groups active")
 592      (list
 593       (read-from-minibuffer "Save current filter groups as: ")
 594       ibuffer-filter-groups)))
 595   (ibuffer-aif (assoc name ibuffer-saved-filter-groups)
 596       (setcdr it groups)
 597     (push (cons name groups) ibuffer-saved-filter-groups))
 598   (ibuffer-maybe-save-stuff)
 599   (ibuffer-update-mode-name))
 600
 601 ;;;###autoload
 602 (defun ibuffer-delete-saved-filter-groups (name)
 603   "Delete saved filter groups with NAME.
 604 They are removed from `ibuffer-saved-filter-groups'."
 605   (interactive
 606    (list
 607     (if (null ibuffer-saved-filter-groups)
 608         (error "No saved filters")
 609       (completing-read "Delete saved filter group: "
 610                        ibuffer-saved-filter-groups nil t))))
 611   (setq ibuffer-saved-filter-groups
 612         (ibuffer-delete-alist name ibuffer-saved-filter-groups))
 613   (ibuffer-maybe-save-stuff)
 614   (ibuffer-update nil t))
 615
 616 ;;;###autoload
 617 (defun ibuffer-switch-to-saved-filter-groups (name)
 618   "Set this buffer's filter groups to saved version with NAME.
 619 The value from `ibuffer-saved-filters' is used.
 620 If prefix argument ADD is non-nil, then add the saved filters instead
 621 of replacing the current filters."
 622   (interactive
 623    (list
 624     (if (null ibuffer-saved-filter-groups)
 625         (error "No saved filters")
 626       (completing-read "Switch to saved filter group: "
 627                        ibuffer-saved-filter-groups nil t))))
 628   (setq ibuffer-filter-groups (cdr (assoc name ibuffer-saved-filter-groups)))
 629   (ibuffer-update nil t))
 630
 631 ;;;###autoload
 632 (defun ibuffer-filter-disable ()
 633   "Disable all filters currently in effect in this buffer."
 634   (interactive)
 635   (setq ibuffer-filtering-qualifiers nil)
 636   (ibuffer-update nil t))
 637
 638 ;;;###autoload
 639 (defun ibuffer-pop-filter ()
 640   "Remove the top filter in this buffer."
 641   (interactive)
 642   (when (null ibuffer-filtering-qualifiers)
 643     (error "No filters in effect"))
 644   (pop ibuffer-filtering-qualifiers)
 645   (ibuffer-update nil t))
 646
 647 (defun ibuffer-push-filter (qualifier)
 648   "Add QUALIFIER to `ibuffer-filtering-qualifiers'."
 649   (push qualifier ibuffer-filtering-qualifiers))
 650
 651 ;;;###autoload
 652 (defun ibuffer-decompose-filter ()
 653   "Separate the top compound filter (OR, NOT, or SAVED) in this buffer.
 654
 655 This means that the topmost filter on the filtering stack, which must
 656 be a complex filter like (OR [name: foo] [mode: bar-mode]), will be
 657 turned into two separate filters [name: foo] and [mode: bar-mode]."
 658   (interactive)
 659   (when (null ibuffer-filtering-qualifiers)
 660     (error "No filters in effect"))
 661   (let ((lim (pop ibuffer-filtering-qualifiers)))
 662     (case (car lim)
 663       (or
 664        (setq ibuffer-filtering-qualifiers (append
 665                                           (cdr lim)
 666                                           ibuffer-filtering-qualifiers)))
 667       (saved
 668        (let ((data
 669               (assoc (cdr lim)
 670                      ibuffer-saved-filters)))
 671          (unless data
 672            (ibuffer-filter-disable)
 673            (error "Unknown saved filter %s" (cdr lim)))
 674          (setq ibuffer-filtering-qualifiers (append
 675                                             (cadr data)
 676                                             ibuffer-filtering-qualifiers))))
 677       (not
 678        (push (cdr lim)
 679              ibuffer-filtering-qualifiers))
 680       (t
 681        (error "Filter type %s is not compound" (car lim)))))
 682   (ibuffer-update nil t))
 683
 684 ;;;###autoload
 685 (defun ibuffer-exchange-filters ()
 686   "Exchange the top two filters on the stack in this buffer."
 687   (interactive)
 688   (when (< (length ibuffer-filtering-qualifiers)
 689            2)
 690     (error "Need two filters to exchange"))
 691   (let ((first (pop ibuffer-filtering-qualifiers))
 692         (second (pop ibuffer-filtering-qualifiers)))
 693     (push first ibuffer-filtering-qualifiers)
 694     (push second ibuffer-filtering-qualifiers))
 695   (ibuffer-update nil t))
 696
 697 ;;;###autoload
 698 (defun ibuffer-negate-filter ()
 699   "Negate the sense of the top filter in the current buffer."
 700   (interactive)
 701   (when (null ibuffer-filtering-qualifiers)
 702     (error "No filters in effect"))
 703   (let ((lim (pop ibuffer-filtering-qualifiers)))
 704     (push (if (eq (car lim) 'not)
 705               (cdr lim)
 706             (cons 'not lim))
 707           ibuffer-filtering-qualifiers))
 708   (ibuffer-update nil t))
 709
 710 ;;;###autoload
 711 (defun ibuffer-or-filter (&optional reverse)
 712   "Replace the top two filters in this buffer with their logical OR.
 713 If optional argument REVERSE is non-nil, instead break the top OR
 714 filter into parts."
 715   (interactive "P")
 716   (if reverse
 717       (progn
 718         (when (or (null ibuffer-filtering-qualifiers)
 719                   (not (eq 'or (caar ibuffer-filtering-qualifiers))))
 720           (error "Top filter is not an OR"))
 721         (let ((lim (pop ibuffer-filtering-qualifiers)))
 722           (setq ibuffer-filtering-qualifiers (nconc (cdr lim) ibuffer-filtering-qualifiers))))
 723     (when (< (length ibuffer-filtering-qualifiers) 2)
 724       (error "Need two filters to OR"))
 725     ;; If the second filter is an OR, just add to it.
 726     (let ((first (pop ibuffer-filtering-qualifiers))
 727           (second (pop ibuffer-filtering-qualifiers)))
 728       (if (eq 'or (car second))
 729           (push (nconc (list 'or first) (cdr second)) ibuffer-filtering-qualifiers)
 730         (push (list 'or first second)
 731               ibuffer-filtering-qualifiers))))
 732   (ibuffer-update nil t))
 733
 734 (defun ibuffer-maybe-save-stuff ()
 735   (when ibuffer-save-with-custom
 736     (if (fboundp 'customize-save-variable)
 737         (progn
 738           (customize-save-variable 'ibuffer-saved-filters
 739                                    ibuffer-saved-filters)
 740           (customize-save-variable 'ibuffer-saved-filter-groups
 741                                    ibuffer-saved-filter-groups))
 742       (message "Not saved permanently: Customize not available"))))
 743
 744 ;;;###autoload
 745 (defun ibuffer-save-filters (name filters)
 746   "Save FILTERS in this buffer with name NAME in `ibuffer-saved-filters'.
 747 Interactively, prompt for NAME, and use the current filters."
 748   (interactive
 749    (if (null ibuffer-filtering-qualifiers)
 750        (error "No filters currently in effect")
 751      (list
 752       (read-from-minibuffer "Save current filters as: ")
 753       ibuffer-filtering-qualifiers)))
 754   (ibuffer-aif (assoc name ibuffer-saved-filters)
 755       (setcdr it filters)
 756       (push (list name filters) ibuffer-saved-filters))
 757   (ibuffer-maybe-save-saved-stuff)
 758   (ibuffer-update-mode-name))
 759
 760 ;;;###autoload
 761 (defun ibuffer-delete-saved-filters (name)
 762   "Delete saved filters with NAME from `ibuffer-saved-filters'."
 763   (interactive
 764    (list
 765     (if (null ibuffer-saved-filters)
 766         (error "No saved filters")
 767       (completing-read "Delete saved filters: "
 768                        ibuffer-saved-filters nil t))))
 769   (setq ibuffer-saved-filters
 770         (ibuffer-delete-alist name ibuffer-saved-filters))
 771   (ibuffer-maybe-save-stuff)
 772   (ibuffer-update nil t))
 773
 774 ;;;###autoload
 775 (defun ibuffer-add-saved-filters (name)
 776   "Add saved filters from `ibuffer-saved-filters' to this buffer's filters."
 777   (interactive
 778    (list
 779     (if (null ibuffer-saved-filters)
 780         (error "No saved filters")
 781       (completing-read "Add saved filters: "
 782                        ibuffer-saved-filters nil t))))
 783   (push (cons 'saved name) ibuffer-filtering-qualifiers)
 784   (ibuffer-update nil t))
 785
 786 ;;;###autoload
 787 (defun ibuffer-switch-to-saved-filters (name)
 788   "Set this buffer's filters to filters with NAME from `ibuffer-saved-filters'.
 789 If prefix argument ADD is non-nil, then add the saved filters instead
 790 of replacing the current filters."
 791   (interactive
 792    (list
 793     (if (null ibuffer-saved-filters)
 794         (error "No saved filters")
 795       (completing-read "Switch to saved filters: "
 796                        ibuffer-saved-filters nil t))))
 797   (setq ibuffer-filtering-qualifiers (list (cons 'saved name)))
 798   (ibuffer-update nil t))
 799
 800 (defun ibuffer-format-qualifier (qualifier)
 801   (if (eq (car-safe qualifier) 'not)
 802       (concat " [NOT" (ibuffer-format-qualifier-1 (cdr qualifier)) "]")
 803     (ibuffer-format-qualifier-1 qualifier)))
 804
 805 (defun ibuffer-format-qualifier-1 (qualifier)
 806   (case (car qualifier)
 807     (saved
 808      (concat " [filter: " (cdr qualifier) "]"))
 809     (or
 810      (concat " [OR" (mapconcat #'ibuffer-format-qualifier
 811                                (cdr qualifier) "") "]"))
 812     (t
 813      (let ((type (assq (car qualifier) ibuffer-filtering-alist)))
 814        (unless qualifier
 815          (error "Ibuffer: bad qualifier %s" qualifier))
 816        (concat " [" (cadr type) ": " (format "%s]" (cdr qualifier)))))))
 817
 818 ;;; Extra operation definitions
 819
 820 (define-ibuffer-filter mode
 821   "Toggle current view to buffers with major mode QUALIFIER."
 822   (:description "major mode"
 823    :reader
 824    (intern
 825     (completing-read "Filter by major mode: " obarray
 826                      #'(lambda (e)
 827                          (string-match "-mode$"
 828                                        (symbol-name e)))
 829                      t
 830                      (let ((buf (ibuffer-current-buffer)))
 831                        (if (and buf (buffer-live-p buf))
 832                            (with-current-buffer buf
 833                              (symbol-name major-mode))
 834                          "")))))
 835   (eq qualifier (with-current-buffer buf major-mode)))
 836
 837 (define-ibuffer-filter name
 838   "Toggle current view to buffers with name matching QUALIFIER."
 839   (:description "buffer name"
 840    :reader
 841    (read-from-minibuffer "Filter by name (regexp): "))
 842   (string-match qualifier (buffer-name buf)))
 843
 844 (define-ibuffer-filter filename
 845   "Toggle current view to buffers with filename matching QUALIFIER."
 846   (:description "filename"
 847    :reader
 848    (read-from-minibuffer "Filter by filename (regexp): "))
 849   (ibuffer-awhen (buffer-file-name buf)
 850     (string-match qualifier it)))
 851
 852 (define-ibuffer-filter size-gt
 853   "Toggle current view to buffers with size greater than QUALIFIER."
 854   (:description "size greater than"
 855    :reader
 856    (string-to-number (read-from-minibuffer "Filter by size greater than: ")))
 857   (> (with-current-buffer buf (buffer-size))
 858      qualifier))
 859
 860 (define-ibuffer-filter size-lt
 861    "Toggle current view to buffers with size less than QUALIFIER."
 862   (:description "size less than"
 863    :reader
 864    (string-to-number (read-from-minibuffer "Filter by size less than: ")))
 865   (< (with-current-buffer buf (buffer-size))
 866      qualifier))
 867
 868 (define-ibuffer-filter content
 869    "Toggle current view to buffers whose contents match QUALIFIER."
 870   (:description "content"
 871    :reader
 872    (read-from-minibuffer "Filter by content (regexp): "))
 873   (with-current-buffer buf
 874     (save-excursion
 875       (goto-char (point-min))
 876       (re-search-forward qualifier nil t))))
 877
 878 (define-ibuffer-filter predicate
 879    "Toggle current view to buffers for which QUALIFIER returns non-nil."
 880   (:description "predicate"
 881    :reader
 882    (read-minibuffer "Filter by predicate (form): "))
 883   (with-current-buffer buf
 884     (eval qualifier)))
 885
 886 ;;; Sorting
 887
 888 ;;;###autoload
 889 (defun ibuffer-toggle-sorting-mode ()
 890   "Toggle the current sorting mode.
 891 Default sorting modes are:
 892  Recency - the last time the buffer was viewed
 893  Alphabetic - the `buffer-name' of the buffer
 894  Major Mode - the `major-mode' of the buffer
 895  Mode Name - the `mode-name' of the buffer
 896  Size - the `buffer-size' of the buffer"
 897   (interactive)
 898   (let ((modes (if (eq ibuffer-toggle-sorting-modes 'all)
 899                    (cons 'recency (mapcar 'car ibuffer-sorting-functions-alist))
 900                  (if (listp ibuffer-toggle-sorting-modes)
 901                      ibuffer-toggle-sorting-modes
 902                    '(alphabetic major-mode mode-name buffer-size)))))
 903     (setq modes (sort modes 'string-lessp))
 904     (let ((next (or (car-safe (cdr-safe (memq ibuffer-sorting-mode modes)))
 905                     (car modes))))
 906       (setq ibuffer-sorting-mode next)
 907       (message "Sorting by %s (%s)"
 908                (if (eq next 'recency)
 909                    "last view time"
 910                  (cadr (assq next ibuffer-sorting-functions-alist)))
 911                next)))
 912   (ibuffer-redisplay t))
 913
 914 ;;;###autoload
 915 (defun ibuffer-invert-sorting ()
 916   "Toggle whether or not sorting is in reverse order."
 917   (interactive)
 918   (setq ibuffer-sorting-reversep (not ibuffer-sorting-reversep))
 919   (message "Sorting order %s"
 920            (if ibuffer-sorting-reversep
 921                "reversed"
 922              "normal"))
 923   (ibuffer-redisplay t))
 924
 925 (define-ibuffer-sorter major-mode
 926   "Sort the buffers by major modes.
 927 Ordering is lexicographic."
 928   (:description "major mode")
 929   (string-lessp (downcase
 930                  (symbol-name (with-current-buffer
 931                                   (car a)
 932                                 major-mode)))
 933                 (downcase
 934                  (symbol-name (with-current-buffer
 935                                   (car b)
 936                                 major-mode)))))
 937
 938 (define-ibuffer-sorter mode-name
 939   "Sort the buffer by mode names.
 940 Ordering is lexicographic."
 941   (:description "major mode name")
 942   (string-lessp (downcase
 943                  (with-current-buffer
 944                      (car a)
 945                    mode-name))
 946                 (downcase
 947                  (with-current-buffer
 948                      (car b)
 949                    mode-name))))
 950
 951 (define-ibuffer-sorter alphabetic
 952   "Sort the buffers by their names.
 953 Ordering is lexicographic."
 954   (:description "buffer name")
 955   (string-lessp
 956    (buffer-name (car a))
 957    (buffer-name (car b))))
 958
 959 (define-ibuffer-sorter size
 960  "Sort the buffers by their size."
 961   (:description "buffer size")
 962   (< (with-current-buffer (car a)
 963        (buffer-size))
 964      (with-current-buffer (car b)
 965        (buffer-size))))
 966
 967 ;;; Functions to emulate bs.el
 968
 969 ;;;###autoload
 970 (defun ibuffer-bs-show ()
 971   "Emulate `bs-show' from the bs.el package."
 972   (interactive)
 973   (ibuffer t "*Ibuffer-bs*" '((filename . ".*")) nil t)
 974   (define-key (current-local-map) "a" 'ibuffer-bs-toggle-all))
 975
 976 (defun ibuffer-bs-toggle-all ()
 977   "Emulate `bs-toggle-show-all' from the bs.el package."
 978   (interactive)
 979   (if ibuffer-filtering-qualifiers
 980       (ibuffer-pop-filter)
 981     (progn (ibuffer-push-filter '(filename . ".*"))
 982            (ibuffer-update nil t))))
 983
 984 ;;; Handy functions
 985
 986 ;;;###autoload
 987 (defun ibuffer-add-to-tmp-hide (regexp)
 988   "Add REGEXP to `ibuffer-tmp-hide-regexps'.
 989 This means that buffers whose name matches REGEXP will not be shown
 990 for this ibuffer session."
 991   (interactive
 992    (list
 993     (read-from-minibuffer "Never show buffers matching: "
 994                           (regexp-quote (buffer-name (ibuffer-current-buffer t))))))
 995   (push regexp ibuffer-tmp-hide-regexps))
 996
 997 ;;;###autoload
 998 (defun ibuffer-add-to-tmp-show (regexp)
 999   "Add REGEXP to `ibuffer-tmp-show-regexps'.
1000 This means that buffers whose name matches REGEXP will always be shown
1001 for this ibuffer session."
1002   (interactive
1003    (list
1004     (read-from-minibuffer "Always show buffers matching: "
1005                           (regexp-quote (buffer-name (ibuffer-current-buffer t))))))
1006   (push regexp ibuffer-tmp-show-regexps))
1007
1008 ;;;###autoload
1009 (defun ibuffer-forward-next-marked (&optional count mark direction)
1010   "Move forward by COUNT marked buffers (default 1).
1011
1012 If MARK is non-nil, it should be a character denoting the type of mark
1013 to move by.  The default is `ibuffer-marked-char'.
1014
1015 If DIRECTION is non-nil, it should be an integer; negative integers
1016 mean move backwards, non-negative integers mean move forwards."
1017   (interactive "P")
1018   (unless count
1019     (setq count 1))
1020   (unless mark
1021     (setq mark ibuffer-marked-char))
1022   (unless direction
1023     (setq direction 1))
1024   ;; Skip the title
1025   (ibuffer-forward-line 0)
1026   (let ((opos (point))
1027         curmark)
1028     (ibuffer-forward-line direction)
1029     (while (not (or (= (point) opos)
1030                     (eq (setq curmark (ibuffer-current-mark))
1031                         mark)))
1032       (ibuffer-forward-line direction))
1033     (when (and (= (point) opos)
1034                (not (eq (ibuffer-current-mark) mark)))
1035       (error "No buffers with mark %c" mark))))
1036
1037 ;;;###autoload
1038 (defun ibuffer-backwards-next-marked (&optional count mark)
1039    "Move backwards by COUNT marked buffers (default 1).
1040
1041 If MARK is non-nil, it should be a character denoting the type of mark
1042 to move by.  The default is `ibuffer-marked-char'."
1043    (interactive "P")
1044    (ibuffer-forward-next-marked count mark -1))
1045
1046 ;;;###autoload
1047 (defun ibuffer-do-kill-lines ()
1048   "Hide all of the currently marked lines."
1049   (interactive)
1050   (if (= (ibuffer-count-marked-lines) 0)
1051       (message "No buffers marked; use 'm' to mark a buffer")
1052     (let ((count
1053            (ibuffer-map-marked-lines
1054             #'(lambda (buf mark)
1055                 'kill))))
1056       (message "Killed %s lines" count))))
1057
1058 ;;;###autoload
1059 (defun ibuffer-jump-to-buffer (name)
1060   "Move point to the buffer whose name is NAME."
1061   (interactive (list nil))
1062   (let ((table (mapcar #'(lambda (x)
1063                            (cons (buffer-name (car x))
1064                                  (caddr x)))
1065                        (ibuffer-current-state-list t))))
1066     (when (null table)
1067       (error "No buffers!"))
1068     (when (interactive-p)
1069       (setq name (completing-read "Jump to buffer: " table nil t)))
1070     (ibuffer-aif (assoc name table)
1071         (goto-char (cdr it))
1072       (error "No buffer with name %s" name))))
1073
1074 ;;;###autoload
1075 (defun ibuffer-diff-with-file ()
1076   "View the differences between this buffer and its associated file.
1077 This requires the external program \"diff\" to be in your `exec-path'."
1078   (interactive)
1079   (let* ((buf (ibuffer-current-buffer))
1080          (buf-filename (with-current-buffer buf
1081                          buffer-file-name)))
1082     (unless (buffer-live-p buf)
1083       (error "Buffer %s has been killed" buf))
1084     (unless buf-filename
1085       (error "Buffer %s has no associated file" buf))
1086     (let ((diff-buf (get-buffer-create "*Ibuffer-diff*")))
1087       (with-current-buffer diff-buf
1088         (setq buffer-read-only nil)
1089         (erase-buffer))
1090       (let ((tempfile (ibuffer-make-temp-file "ibuffer-diff-")))
1091         (unwind-protect
1092             (progn
1093               (with-current-buffer buf
1094                 (write-region (point-min) (point-max) tempfile nil 'nomessage))
1095               (if (zerop
1096                    (apply #'call-process "diff" nil diff-buf nil
1097                           (append
1098                            (when (and (boundp 'ediff-custom-diff-options)
1099                                       (stringp ediff-custom-diff-options))
1100                              (list ediff-custom-diff-options))
1101                            (list buf-filename tempfile))))
1102                   (message "No differences found")
1103                 (progn
1104                   (with-current-buffer diff-buf
1105                     (goto-char (point-min))
1106                     (if (fboundp 'diff-mode)
1107                         (diff-mode)
1108                       (fundamental-mode)))
1109                   (display-buffer diff-buf))))
1110           (when (file-exists-p tempfile)
1111             (delete-file tempfile)))))
1112       nil))
1113
1114 ;;;###autoload
1115 (defun ibuffer-copy-filename-as-kill (&optional arg)
1116   "Copy filenames of marked buffers into the kill ring.
1117 The names are separated by a space.
1118 If a buffer has no filename, it is ignored.
1119 With a zero prefix arg, use the complete pathname of each marked file.
1120
1121 You can then feed the file name(s) to other commands with C-y.
1122
1123  [ This docstring shamelessly stolen from the
1124  `dired-copy-filename-as-kill' in \"dired-x\". ]"
1125   ;; Add to docstring later:
1126   ;; With C-u, use the relative pathname of each marked file.
1127   (interactive "P")
1128   (if (= (ibuffer-count-marked-lines) 0)
1129       (message "No buffers marked; use 'm' to mark a buffer")
1130     (let ((ibuffer-copy-filename-as-kill-result "")
1131           (type (cond ((eql arg 0)
1132                        'full)
1133                       ;; ((eql arg 4)
1134                       ;;  'relative)
1135                       (t
1136                        'name))))
1137       (ibuffer-map-marked-lines
1138        #'(lambda (buf mark)
1139            (setq ibuffer-copy-filename-as-kill-result
1140                  (concat ibuffer-copy-filename-as-kill-result
1141                          (let ((name (buffer-file-name buf)))
1142                            (if name
1143                                (case type
1144                                  (full
1145                                   name)
1146                                  (t
1147                                   (file-name-nondirectory name)))
1148                              ""))
1149                          " "))))
1150       (push ibuffer-copy-filename-as-kill-result kill-ring))))
1151
1152 (defun ibuffer-mark-on-buffer (func &optional ibuffer-mark-on-buffer-mark group)
1153   (let ((count
1154          (ibuffer-map-lines
1155           #'(lambda (buf mark)
1156               (when (funcall func buf)
1157                 (ibuffer-set-mark-1 (or ibuffer-mark-on-buffer-mark
1158                                         ibuffer-marked-char))
1159                 t))
1160           nil
1161           group)))
1162     (ibuffer-redisplay t)
1163     (message "Marked %s buffers" count)))
1164
1165 ;;;###autoload
1166 (defun ibuffer-mark-by-name-regexp (regexp)
1167   "Mark all buffers whose name matches REGEXP."
1168   (interactive "sMark by name (regexp): ")
1169   (ibuffer-mark-on-buffer
1170    #'(lambda (buf)
1171        (string-match regexp (buffer-name buf)))))
1172
1173 ;;;###autoload
1174 (defun ibuffer-mark-by-mode-regexp (regexp)
1175   "Mark all buffers whose major mode matches REGEXP."
1176   (interactive "sMark by major mode (regexp): ")
1177   (ibuffer-mark-on-buffer
1178    #'(lambda (buf)
1179        (with-current-buffer buf
1180          (string-match regexp mode-name)))))
1181
1182 ;;;###autoload
1183 (defun ibuffer-mark-by-file-name-regexp (regexp)
1184   "Mark all buffers whose file name matches REGEXP."
1185   (interactive "sMark by file name (regexp): ")
1186   (ibuffer-mark-on-buffer
1187    #'(lambda (buf)
1188        (let ((name (or (buffer-file-name buf)
1189                        (with-current-buffer buf
1190                          (and
1191                           (boundp 'dired-directory)
1192                           (stringp dired-directory)
1193                           dired-directory)))))
1194          (when name
1195            (string-match regexp name))))))
1196
1197 ;;;###autoload
1198 (defun ibuffer-mark-by-mode (mode)
1199   "Mark all buffers whose major mode equals MODE."
1200   (interactive
1201    (list (intern (completing-read "Mark by major mode: " obarray
1202                                   #'(lambda (e)
1203                                       ;; kind of a hack...
1204                                       (and (fboundp e)
1205                                            (string-match "-mode$"
1206                                                          (symbol-name e))))
1207                                   t
1208                                   (let ((buf (ibuffer-current-buffer)))
1209                                     (if (and buf (buffer-live-p buf))
1210                                         (with-current-buffer buf
1211                                           (cons (symbol-name major-mode)
1212                                                 0))
1213                                       ""))))))
1214   (ibuffer-mark-on-buffer
1215    #'(lambda (buf)
1216        (with-current-buffer buf
1217          (eq major-mode mode)))))
1218
1219 ;;;###autoload
1220 (defun ibuffer-mark-modified-buffers ()
1221   "Mark all modified buffers."
1222   (interactive)
1223   (ibuffer-mark-on-buffer
1224    #'(lambda (buf) (buffer-modified-p buf))))
1225
1226 ;;;###autoload
1227 (defun ibuffer-mark-unsaved-buffers ()
1228   "Mark all modified buffers that have an associated file."
1229   (interactive)
1230   (ibuffer-mark-on-buffer
1231    #'(lambda (buf) (and (with-current-buffer buf buffer-file-name)
1232                         (buffer-modified-p buf)))))
1233
1234 ;;;###autoload
1235 (defun ibuffer-mark-dissociated-buffers ()
1236   "Mark all buffers whose associated file does not exist."
1237   (interactive)
1238   (ibuffer-mark-on-buffer
1239    #'(lambda (buf)
1240        (with-current-buffer buf
1241          (or
1242           (and buffer-file-name
1243                (not (file-exists-p buffer-file-name)))
1244           (and (eq major-mode 'dired-mode)
1245                (boundp 'dired-directory)
1246                (stringp dired-directory)
1247                (not (file-exists-p (file-name-directory dired-directory)))))))))
1248
1249 ;;;###autoload
1250 (defun ibuffer-mark-help-buffers ()
1251   "Mark buffers like *Help*, *Apropos*, *Hyper Apropos*, *Info*."
1252   (interactive)
1253   (ibuffer-mark-on-buffer
1254    #'(lambda (buf)
1255        (with-current-buffer buf
1256          (memq major-mode ibuffer-help-buffer-modes)))))
1257
1258 ;;;###autoload
1259 (defun ibuffer-mark-old-buffers ()
1260   "Mark buffers which have not been viewed in `ibuffer-old-time' hours."
1261   (interactive)
1262   (ibuffer-mark-on-buffer
1263    #'(lambda (buf)
1264        (with-current-buffer buf
1265          ;; hacked from midnight.el
1266          (let ((bdt (if (boundp 'ibuffer-buffer-display-time)
1267                         ibuffer-buffer-display-time
1268                       buffer-display-time)))
1269            (when bdt
1270              (let* ((tm (current-time))
1271                     (now (+ (* (float (ash 1 16)) (car tm))
1272                             (float (cadr tm)) (* 0.0000001 (caddr tm))))
1273                     (then (+ (* (float (ash 1 16))
1274                                 (car bdt))
1275                              (float (cadr bdt))
1276                              (* 0.0000001 (caddr bdt)))))
1277                (> (- now then) (* 60 60 ibuffer-old-time)))))))))
1278
1279 ;;;###autoload
1280 (defun ibuffer-mark-special-buffers ()
1281   "Mark all buffers whose name begins and ends with '*'."
1282   (interactive)
1283   (ibuffer-mark-on-buffer
1284    #'(lambda (buf) (string-match "^\\*.+\\*$"
1285                                  (buffer-name buf)))))
1286
1287 ;;;###autoload
1288 (defun ibuffer-mark-read-only-buffers ()
1289   "Mark all read-only buffers."
1290   (interactive)
1291   (ibuffer-mark-on-buffer
1292    #'(lambda (buf)
1293        (with-current-buffer buf
1294          buffer-read-only))))
1295
1296 ;;;###autoload
1297 (defun ibuffer-mark-dired-buffers ()
1298   "Mark all `dired' buffers."
1299   (interactive)
1300   (ibuffer-mark-on-buffer
1301    #'(lambda (buf)
1302        (with-current-buffer buf
1303          (eq major-mode 'dired-mode)))))
1304
1305 ;;; An implementation of multi-buffer `occur'
1306
1307 (defvar ibuffer-occur-props nil)
1308 (make-variable-buffer-local 'ibuffer-occur-props)
1309
1310 (define-derived-mode ibuffer-occur-mode occur-mode "Ibuffer-Occur"
1311   "A special form of Occur mode for multiple buffers.
1312 Note this major mode is not meant for interactive use!
1313 See also `occur-mode'."
1314   (define-key ibuffer-occur-mode-map (kbd "n") 'forward-line)
1315   (define-key ibuffer-occur-mode-map (kbd "q") 'bury-buffer)
1316   (define-key ibuffer-occur-mode-map (kbd "p") 'previous-line)
1317   (define-key ibuffer-occur-mode-map (kbd "RET") 'ibuffer-occur-display-occurence)
1318   (define-key ibuffer-occur-mode-map (kbd "f") 'ibuffer-occur-goto-occurence)
1319   (define-key ibuffer-occur-mode-map [button2] 'ibuffer-occur-mouse-display-occurence)
1320   (set (make-local-variable 'revert-buffer-function)
1321        #'ibuffer-occur-revert-buffer-function)
1322   (set (make-local-variable 'ibuffer-occur-props) nil)
1323   (setq buffer-read-only nil)
1324   (erase-buffer)
1325   (setq buffer-read-only t)
1326   (message (concat
1327             "Use RET "
1328             (if (or (and (< 21 emacs-major-version)
1329                          window-system)
1330                     (featurep 'mouse))
1331                "or button2 ")
1332             "to display an occurence.")))
1333
1334 (defun ibuffer-occur-mouse-display-occurence (e)
1335   "Display occurence on this line in another window."
1336   (interactive "e")
1337   (let* ((occurbuf (window-buffer (ibuffer-event-window e)))
1338          (target (with-current-buffer occurbuf
1339                    (get-text-property (ibuffer-event-position e)
1340                                       'ibuffer-occur-target))))
1341     (unless target
1342       (error "No occurence on this line"))
1343     (let ((buf (car target))
1344           (line (cdr target)))
1345       (switch-to-buffer occurbuf)
1346       (delete-other-windows)
1347       (pop-to-buffer buf)
1348       (goto-line line))))
1349
1350 (defun ibuffer-occur-goto-occurence ()
1351   "Switch to the buffer which has the occurence on this line."
1352   (interactive)
1353   (ibuffer-occur-display-occurence t))
1354
1355 (defun ibuffer-occur-display-occurence (&optional goto)
1356   "Display occurence on this line in another window."
1357   (interactive "P")
1358   (let ((target (get-text-property (point) 'ibuffer-occur-target)))
1359     (unless target
1360       (error "No occurence on this line"))
1361     (let ((buf (car target))
1362           (line (cdr target)))
1363       (delete-other-windows)
1364       (if goto
1365           (switch-to-buffer buf)
1366         (pop-to-buffer buf))
1367       (goto-line line))))
1368
1369 ;;;###autoload
1370 (defun ibuffer-do-occur (regexp &optional nlines)
1371   "View lines which match REGEXP in all marked buffers.
1372 Optional argument NLINES says how many lines of context to display: it
1373 defaults to one."
1374   (interactive
1375    (list (let* ((default (car regexp-history))
1376                 (input
1377                  (read-from-minibuffer
1378                   (if default
1379                       (format "List lines matching regexp (default `%s'): "
1380                               default)
1381                     "List lines matching regexp: ")
1382                   nil
1383                   nil
1384                   nil
1385                   'regexp-history)))
1386            (if (equal input "")
1387                default
1388              input))
1389          current-prefix-arg))
1390   (if (or (not (integerp nlines))
1391           (< nlines 0))
1392       (setq nlines 1))
1393   (when (zerop (ibuffer-count-marked-lines))
1394     (ibuffer-set-mark ibuffer-marked-char))
1395   (let ((ibuffer-do-occur-bufs nil))
1396     ;; Accumulate a list of marked buffers
1397     (ibuffer-map-marked-lines
1398      #'(lambda (buf mark)
1399          (push buf ibuffer-do-occur-bufs)))
1400     (ibuffer-do-occur-1 regexp ibuffer-do-occur-bufs
1401                         (get-buffer-create "*Ibuffer-occur*")
1402                         nlines)))
1403
1404 (defun ibuffer-do-occur-1 (regexp buffers out-buf nlines)
1405   (let ((count (ibuffer-occur-engine regexp buffers out-buf nlines)))
1406     (if (> count 0)
1407         (progn
1408           (switch-to-buffer out-buf)
1409           (setq buffer-read-only t)
1410           (delete-other-windows)
1411           (goto-char (point-min))
1412           (message "Found %s matches in %s buffers" count (length buffers)))
1413       (message "No matches found"))))
1414
1415
1416 (defun ibuffer-occur-revert-buffer-function (ignore-auto noconfirm)
1417   "Update the *Ibuffer occur* buffer."
1418   (assert (eq major-mode 'ibuffer-occur-mode))
1419   (ibuffer-do-occur-1 (car ibuffer-occur-props)
1420                       (cadr ibuffer-occur-props)
1421                       (current-buffer)
1422                       (caddr ibuffer-occur-props)))
1423
1424 (defun ibuffer-occur-engine (regexp buffers out-buf nlines)
1425   (macrolet ((insert-get-point
1426               (&rest args)
1427               `(progn
1428                  (insert ,@args)
1429                  (point)))
1430              (maybe-put-text-property
1431               (beg end &rest args)
1432               `(when ibuffer-use-fontification
1433                  (put-text-property ,beg ,end ,@args)))
1434              (maybe-ibuffer-propertize
1435               (obj &rest args)
1436               (let ((objsym (gensym "--maybe-ibuffer-propertize-")))
1437                 `(let ((,objsym ,obj))
1438                    (if ibuffer-use-fontification
1439                        (ibuffer-propertize ,objsym ,@args)
1440                      ,objsym)))))
1441     (with-current-buffer out-buf
1442       (ibuffer-occur-mode)
1443       (setq buffer-read-only nil)
1444       (let ((globalcount 0))
1445         ;; Map over all the buffers
1446         (dolist (buf buffers)
1447           (when (buffer-live-p buf)
1448             (let ((c 0) ;; count of matched lines
1449                   (l 1) ;; line count
1450                   (headerpt (with-current-buffer out-buf (point))))
1451               (save-excursion
1452                 (set-buffer buf)
1453                 (save-excursion
1454                   (goto-char (point-min)) ;; begin searching in the buffer
1455                   (while (not (eobp))
1456                     ;; The line we're matching against
1457                     (let ((curline (buffer-substring
1458                                     (ibuffer-line-beginning-position)
1459                                     (ibuffer-line-end-position))))
1460                       (when (string-match regexp curline)
1461                         (incf c) ;; increment match count
1462                         (incf globalcount)
1463                         ;; Depropertize the string, and maybe highlight the matches
1464                         (setq curline
1465                               (progn
1466                                 (ibuffer-depropertize-string curline t)
1467                                 (when ibuffer-use-fontification
1468                                   (let ((len (length curline))
1469                                         (start 0))
1470                                     (while (and (< start len)
1471                                                 (string-match regexp curline start))
1472                                       (put-text-property (match-beginning 0)
1473                                                          (match-end 0)
1474                                                          'face ibuffer-occur-match-face
1475                                                          curline)
1476                                       (setq start (match-end 0)))))
1477                                 curline))
1478                         ;; Generate the string to insert for this match
1479                         (let ((data
1480                                (if (= nlines 1)
1481                                    ;; The simple display style
1482                                    (concat (maybe-ibuffer-propertize
1483                                             (format "%-6d:" l)
1484                                             'face 'bold)
1485                                            curline
1486                                            "\n")
1487                                  ;; The complex multi-line display style
1488                                  (let ((prevlines (nreverse
1489                                                    (ibuffer-accumulate-lines (- nlines))))
1490                                        (nextlines (ibuffer-accumulate-lines nlines))
1491                                        ;; The lack of `flet' seriously sucks.
1492                                        (fun #'(lambda (lines)
1493                                                 (mapcar
1494                                                  #'(lambda (line)
1495                                                      (concat "      :" line "\n"))
1496                                                  lines))))
1497                                    (setq prevlines (funcall fun prevlines))
1498                                    (setq nextlines (funcall fun nextlines))
1499                                    ;; Yes, I am trying to win the award for the
1500                                    ;; most consing.
1501                                    (apply #'concat
1502                                           (nconc
1503                                            prevlines
1504                                            (list
1505                                             (concat
1506                                              (maybe-ibuffer-propertize
1507                                               (format "%-6d" l)
1508                                               'face 'bold)
1509                                              ":"
1510                                              curline
1511                                              "\n"))
1512                                            nextlines))))))
1513                           ;; Actually insert the match display data
1514                           (with-current-buffer out-buf
1515                             (let ((beg (point))
1516                                   (end (insert-get-point
1517                                         data)))
1518                               (unless (= nlines 1)
1519                                 (insert "-------\n"))
1520                               (put-text-property
1521                                beg (1- end) 'ibuffer-occur-target (cons buf l))
1522                               (put-text-property
1523                                beg (1- end) 'mouse-face 'highlight))))))
1524                     ;; On to the next line...
1525                     (incf l)
1526                     (forward-line 1))))
1527               (when (not (zerop c)) ;; is the count zero?
1528                 (with-current-buffer out-buf
1529                   (goto-char headerpt)
1530                   (let ((beg (point))
1531                         (end (insert-get-point
1532                               (format "%d lines matching \"%s\" in buffer %s\n"
1533                                       c regexp (buffer-name buf)))))
1534                     (maybe-put-text-property beg (1- end) 'face 'underline))
1535                   (goto-char (point-max)))))))
1536         (setq ibuffer-occur-props (list regexp buffers nlines))
1537         ;; Return the number of matches
1538         globalcount))))
1539
1540 (provide 'ibuf-ext)
1541
1542 ;;; ibuf-ext.el ends here