home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / modes / GTbuf-men.el < prev    next >
Encoding:
Text File  |  1993-01-31  |  32.6 KB  |  917 lines
  1. ;;;; GTbuf-men.el - more dired-like buffer menu
  2.  
  3. (defconst GTbuf-men-version (substring "$Revision: 1.25 $" 11 -2)
  4.   "$Id: GTbuf-men.el,v 1.25 1992/12/13 22:30:45 wurgler Exp wurgler $")
  5.  
  6. ;; Copyright (C) 1991 by Bill Benedetto and Tom Wurgler
  7.  
  8. ;; This program is free software; you can redistribute it and/or modify
  9. ;; it under the terms of the GNU General Public License as published by
  10. ;; the Free Software Foundation; either version 1, or (at your option)
  11. ;; any later version.
  12. ;;
  13. ;; This program is distributed in the hope that it will be useful,
  14. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16. ;; GNU General Public License for more details.
  17. ;;
  18. ;; You should have received a copy of the GNU General Public License
  19. ;; along with this program; if not, write to the Free Software
  20. ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  21.  
  22. ;; LISPDIR ENTRY for the Elisp Archive ===============================
  23. ;;    LCD Archive Entry:
  24. ;;    GTbuf-men|Tom Wurgler and Bill Benedetto|
  25. ;;    wurgler@gentire.com and benedett@gentire.com|
  26. ;;    More dired-like buffer menu|
  27. ;;    1992-12-13|1.25|~/modes/GTbuf-men.el.Z|
  28.  
  29. ;; INSTALLATION ======================================================
  30. ;; 
  31. ;; Put this file into your load-path and the following in your ~/.emacs:
  32. ;; 
  33. ;;   (autoload 'buffer-menu-dired-extended "GTbuf-men")
  34. ;;   (define-key ctl-x-map "\C-b" 'buffer-menu-dired-extended)
  35.  
  36. ;; OVERVIEW ==========================================================
  37. ;
  38. ; extended buff-menu functions
  39. ;
  40. ;      Global keybinding:
  41. ;          \C-c\C-j - switch to buffer list
  42. ;
  43. ;      Buffer-menu mode keybindings
  44. ;          %d - mark buffers for deletion containing regexp
  45. ;          %m - mark buffers for viewing containing regexp
  46. ;          m - mark the next ARG buffers
  47. ;          M-del - unflag all buffers
  48. ;          M-< - goto the first buffer
  49. ;          M-> - goto the last buffer
  50. ;          M-{ - goto the next marked buffer
  51. ;          M-} - goto the previous marked buffer
  52. ;          F - display marked buffers
  53. ;          L - display the buffer list based on files only, direds only, plain
  54. ;              buffers (those not associated with a file) or all buffers
  55. ;          R - list only buffers containing regexp
  56. ;       S - sort the buffer list
  57. ;       g - to revert a buffer list
  58. ;       q - quit buffer-menu
  59. ;       r - rename the buffer
  60. ;       w - copy the marked or current buffer name(s) to the kill ring
  61. ;     C-n, n - go to the next buffer line and postion on the name
  62. ;     C-p, p - go to the previous buffer line and postion on the name
  63. ;          N - display next buffer in another window
  64. ;          P - display previous buffer in another window
  65. ;          J - display this buffer in another window
  66. ;          T - switches marked and unmarked buffers
  67. ;          X - deletes marked buffers
  68. ;
  69. ; This package is based on and requires Sebastian Kremer's dired and gmhist 
  70. ; code, which can be otained via anonymous ftp from:
  71. ;
  72. ;       ftp.thp.Uni-Koeln.DE[134.95.64.1]:/pub/gnu/emacs/diredall.tar.Z
  73. ;       ftp.thp.Uni-Koeln.DE[134.95.64.1]:/pub/gnu/emacs/gmhist.tar.Z
  74. ;
  75. ; Many thanks to Sebastian for all the clean code for dired and the start
  76. ; of this package, and his helpful comments and debugging of this code.
  77. ;
  78. ; Also, thanks to Larry Dodd for acting as a beta tester and for his many
  79. ; suggestions for improving the code.
  80. ;
  81. ; Bill Benedetto and Tom Wurgler,  wurgler@gentire.com
  82. ;
  83.  
  84. (require 'dired)
  85. (require 'gmhist)
  86.  
  87. (defvar buffer-menu-restricted nil
  88.   "Whether buffer-menu is restricted by regexp, sort, files or direds.")
  89.  
  90. (defvar buffer-menu-full-screen nil
  91.   "*If t, use the full screen when displaying marked buffers using 'F'.")
  92.  
  93. (defvar buffer-menu-confirm-deletes t
  94.   "*In buffer menu, if non-nil will ask you to confirm deletions.
  95. If nil, you will not be asked if you want to make deletes --
  96. they will just be done.")
  97.  
  98. (defvar buffer-marker-char ?>
  99.   "In buffer menu, character used to mark buffers for later commands.")
  100.  
  101. (defvar buffer-delete-marker ?D
  102.   "In buffer menu, character used to mark buffers for later deletions.")
  103.  
  104. (defvar buffer-options ""
  105.   "*Contains the last string of buffer-menu-options such as sort, regexp etc.")
  106.  
  107. (defvar buffer-menu-regexp nil
  108.   "*Contains the last regexp used in buffer-menu.")
  109.  
  110. (defvar buffer-menu-list nil
  111.   "*In buffer menu, contains a list of the marked buffers.")
  112.  
  113. (defvar buffer-menu-ignore-modified-regexp "^\\*"
  114.   "Buffers matching this regexp are marked as unmodified in the
  115. buffer menu.")
  116.  
  117. (defvar buffer-menu-strange-buf-regexp "\
  118. ^... \\*Buffer List\\*\\|\
  119. ^... \\*Messages\\*"
  120.  
  121. "These buffers must have their modified mark cleared after the listing
  122. has been made.")
  123.  
  124. (defvar buffer-menu-ignore-modified-modes '(ange-ftp-shell-mode)
  125.   "Buffers in this mode will show up unmodified in the buffer menu.")
  126.  
  127. (defvar buffer-menu-mode-options nil
  128.   "Whether buffer-menu lists by regexp or files only or etc.")
  129.  
  130. (defconst buffer-menu-modified-mark-column 1)
  131.  
  132. (defun buffer-menu-dired-extended (&optional buff-opt fromp)
  133.   "Make a menu of buffers so you can save, delete or select them.
  134. With \\[universal-argument] you will be allowed to choose whether you want just
  135. files, just direds or plain buffers and whether or not you want the list 
  136. sorted.  Type ? after invocation to get help on commands available.
  137. Type \\[Buffer-menu-quit] immediately to make the buffer menu go away."
  138.   (interactive)
  139.   (if (or current-prefix-arg (and buffer-menu-restricted fromp))
  140.       (let ((buffer-menu-opts "")
  141.         (buffer-menu-sort-it nil))
  142.     (if (not buff-opt)
  143.         (setq buffer-menu-opts
  144.           (read-string "Choose direds or files or plain buffers, regexp, sort (d/f/n,r,s): "))
  145.       (setq buffer-menu-opts buff-opt))
  146.     (setq buffer-options buffer-menu-opts)
  147.     (if (not (string-equal buffer-menu-opts ""))
  148.         (progn
  149.           (setq buffer-menu-restricted t)
  150.           (if (string-match "s" buffer-menu-opts)
  151.           (setq buffer-menu-sort-it t))
  152.           (if (string-match "r" buffer-menu-opts)
  153.           (if (not buff-opt)
  154.               (setq buffer-menu-regexp (read-with-history-in
  155.                         'buffer-menu-regexp-history
  156.                         "Regexp: ")))
  157.         (setq buffer-menu-regexp nil))
  158.           (if (string-match "f" buffer-menu-opts)
  159.           (buffer-menu t)
  160.         (buffer-menu nil))
  161.           (if (string-match "n" buffer-menu-opts)
  162.           (let ((buffer-read-only nil))
  163.             (delete-matching-lines "[0-9]+[ \t]+Dired[ \t]*")
  164.             (Buffer-menu-goto-first-buffer)
  165.             (while (not (eobp))
  166.               (if (buffer-file-name (Buffer-menu-buffer nil))
  167.               (delete-region (progn (beginning-of-line) (point))
  168.                      (progn (forward-line 1) (point)))
  169.             (forward-line 1)))
  170.             (Buffer-menu-goto-first-buffer)
  171.             (delete-region (point-min) (point))
  172.             (insert "\
  173.  MR Buffer         Size  Mode\n\
  174.  -- ------         ----  ----\n")
  175.             (Buffer-menu-goto-first-buffer)))
  176.           (if (string-match "d" buffer-menu-opts)
  177.           (let ((buffer-read-only nil) buf dir)
  178.             ;; Epoch 3.2 appends the filename for dired buffers
  179.             (keep-lines "[0-9]+[ \t]+Dired[ \t]*")    ; ugh
  180.             (Buffer-menu-goto-first-buffer)
  181.             (delete-region 1 (point))
  182.             (insert "\
  183.  MR Buffer         Size  Mode           Directory\n\
  184.  -- ------         ----  ----           ---------\n")
  185.             (or (string-match "^3\\.2" emacs-version)
  186.             ;; Epoch 3.2 appends the filename for dired buffers
  187.             (save-excursion
  188.               (while (not (eobp))
  189.                 (if (setq buf (Buffer-menu-buffer nil))
  190.                 (progn
  191.                   (save-excursion
  192.                     (set-buffer buf)
  193.                     (setq dir (or (and (boundp
  194.                             'dired-directory)
  195.                                dired-directory)
  196.                           ;; 18.55 Dired does not
  197.                           ;; have this variable
  198.                           default-directory)))
  199.                   (end-of-line)
  200.                   (insert dir)))
  201.                 (forward-line))))))
  202.           (if buffer-menu-sort-it 
  203.           (let ((buffer-read-only nil))
  204.             (require 'sort)
  205.             (Buffer-menu-goto-first-buffer)
  206.             (sort-subr nil 'forward-line 'end-of-line
  207.                    'Buffer-menu-buffer-no-arg)
  208.             (Buffer-menu-goto-first-buffer)))
  209.           (if buffer-menu-regexp
  210.           (let ((buffer-read-only nil))
  211.             (Buffer-menu-goto-first-buffer)
  212.             (buffer-mark-files-regexp buffer-menu-regexp "_")
  213.             (keep-lines "^_.. ")
  214.             (buffer-unflag-all-files "_")
  215.             (message "")
  216.             (Buffer-menu-goto-first-buffer))))
  217.       (buffer-menu nil)
  218.       (setq buffer-menu-restricted nil)))
  219.     (setq buffer-options "")
  220.     (setq buffer-menu-restricted nil)
  221.     (buffer-menu nil))
  222.   (buffer-menu-list-options)
  223.   (make-local-variable 'buffer-menu-restricted)
  224.   (make-local-variable 'buffer-menu-mode-options)
  225.   (setq buffer-menu-restricted nil)
  226.   (run-hooks 'buffer-menu-hook)
  227.   (buffer-menu-move-to-name)
  228.   (message "q to quit, ? for help."))
  229.  
  230.  
  231.  
  232. (defun Buffer-menu-buffer (error-if-non-existent-p)
  233.   "Return buffer described by this line of buffer menu."
  234.   (if (<= (buffer-menu-cur-line) 2)
  235.       (error "Must point at a buffer."))
  236.   (save-excursion
  237.     (beginning-of-line)
  238.     (if (eobp) (forward-line -1))
  239.     (forward-char Buffer-menu-buffer-column)
  240.     (let ((start (point))
  241.       string)
  242.       ;; End of buffer name marked by tab or two spaces.
  243.       (re-search-forward "\t\\|  ")
  244.       (skip-chars-backward " \t")
  245.       (setq string (buffer-substring start (point)))
  246.       (or (get-buffer string)
  247.       (if error-if-non-existent-p
  248.           (error "No buffer named \"%s\"" string)
  249.         nil)))))
  250.  
  251. (defun Buffer-menu-buffer-no-arg ()
  252.   "Return buffer described by this line of buffer menu.
  253. A version of the original except this one doesn't require an arg."
  254.   (if (<= (buffer-menu-cur-line) 2)
  255.       (error "Must point at a buffer."))
  256.   (save-excursion
  257.     (beginning-of-line)
  258.     (if (eobp) (forward-line -1))
  259.     (forward-char Buffer-menu-buffer-column)
  260.     (let ((start (point))
  261.       string)
  262.       ;; End of buffer name marked by tab or two spaces.
  263.       (re-search-forward "\t\\|  ")
  264.       (skip-chars-backward " \t")
  265.       (buffer-substring start (point)))))
  266.  
  267.  
  268. ;; Make the `modified' marker in buffer menu more meaningful by
  269. ;; putting buffer-menu-set-some-buffers-unmodified on buffer-menu-hook.
  270.  
  271. (defun dired-pending-marks-p ()
  272.   (save-excursion
  273.     (goto-char (point-min))
  274.     (re-search-forward dired-re-mark nil t)))
  275.       
  276. (defun dired-set-buffer-modified-p ()
  277.   "Mark all Dired buffers as modified iff there are pending marks."
  278.   (interactive)
  279.   (let ((blist (buffer-list)))
  280.     (while blist
  281.       (save-excursion
  282.     (set-buffer (car blist))
  283.     (setq blist (cdr blist))
  284.     (if (eq major-mode 'dired-mode)
  285.         (set-buffer-modified-p (dired-pending-marks-p)))))))
  286.  
  287. (defun set-some-buffers-unmodified (name-regexp major-modes)
  288.   "Clears the modification flag of buffers whose names match NAME-REGEXP
  289. or whose major mode is a member of MAJOR-MODES.  Either or both of the
  290. arguments may be nil.
  291. Also sets dired buffer modification flags according to dired-pending-marks-p."
  292.   (let ((blist (buffer-list)))
  293.     (while blist
  294.       (save-excursion
  295.     (set-buffer (car blist))
  296.     (setq blist (cdr blist))
  297.     (cond ((eq major-mode 'dired-mode)
  298.            (set-buffer-modified-p (dired-pending-marks-p)))
  299.           ((buffer-modified-p)
  300.            ;; Don't do the work unless the buffer is marked modified.
  301.            (if (or (memq major-mode major-modes)
  302.                (and name-regexp
  303.                 (string-match name-regexp (buffer-name))))
  304.            (set-buffer-modified-p nil))))))))
  305.  
  306. (defun buffer-menu-set-some-buffers-unmodified ()
  307.   "Useful on `buffer-menu-hook' to make the modified marker in the
  308. buffer menu more meaningful."
  309.   (set-some-buffers-unmodified buffer-menu-ignore-modified-regexp
  310.                    buffer-menu-ignore-modified-modes)
  311.   (save-excursion
  312.     (buffer-menu-home-to-tilde)
  313.     (let ((buffer-read-only nil))
  314.       (goto-char (point-min))
  315.       ;; These buffers are modified during the listing, so
  316.       ;; set-buffer-modified-p is too late.
  317.       (while (re-search-forward buffer-menu-strange-buf-regexp nil t)
  318.     (move-to-column buffer-menu-modified-mark-column)
  319.     (delete-char 1)
  320.     (insert " ")))))
  321.  
  322. ;; Move to next and previous marked buffer line.
  323.  
  324. (defun buffer-menu-next-marked-buffer (arg &optional wrap opoint string)
  325.   "Move to the next marked buffer, wrapping around the end of the buffer list."
  326.   (interactive "p\np")
  327.   (or opoint (setq opoint (point)));; return to where interactively started
  328.   (or string (setq string (concat "\n" (char-to-string buffer-marker-char))))
  329.   (if (if (> arg 0)
  330.       (search-forward string nil t arg)
  331.     (beginning-of-line)
  332.     (if (search-backward string nil t (- arg))
  333.         (search-forward string)))
  334.       (buffer-menu-move-to-name);; or the re-search will get stuck
  335.     (if (null wrap)
  336.     (progn
  337.       (goto-char opoint)
  338.       (error "No next marked buffer!"))
  339.       (message "(Wraparound for next marked buffer)")
  340.       (goto-char (if (> arg 0) (point-min) (point-max)))
  341.       (buffer-menu-next-marked-buffer arg nil opoint))))
  342.  
  343. (defun buffer-menu-prev-marked-buffer (arg &optional wrap)
  344.   "Move to the previous marked buffer, wrapping around the end of the
  345. buffer list."
  346.   (interactive "p\np")
  347.   (buffer-menu-next-marked-buffer (- arg) wrap))
  348.  
  349. (defconst buffer-menu-name-column 4)
  350.  
  351. (defun buffer-menu-move-to-name ()
  352.   (move-to-column buffer-menu-name-column))
  353.  
  354. (defun buffer-mark-files-regexp (regexp &optional marker-char)
  355.   "Mark all buffers matching REGEXP for use in later commands.
  356. A prefix argument means to unmark them instead."
  357.   (interactive
  358.    (list (dired-read-regexp (concat (if current-prefix-arg "Unmark" "Mark")
  359.                     " buffers (regexp): "))
  360.      (if current-prefix-arg ?\040)))
  361.   (let ((dired-marker-char (or marker-char buffer-marker-char)))
  362.     (save-excursion
  363.       (Buffer-menu-goto-first-buffer)
  364.       (save-restriction
  365.     (narrow-to-region (point) (point-max))
  366.     (dired-mark-if
  367.      (and (not (eolp))        ; empty line
  368.           (let ((fn (buffer-name (Buffer-menu-buffer t))))
  369.         (and fn (string-match regexp fn))))
  370.      "matching buffer")))))
  371.  
  372. (defun buffer-flag-regexp-files (regexp)
  373.   "In buffer-menu, flag all buffers containing the specified REGEXP for deletion.
  374. Use `^' and `$' to anchor matches."
  375.   (interactive (list (dired-read-regexp "Flag for deletion (regexp): ")))
  376.   (buffer-mark-files-regexp regexp buffer-delete-marker))
  377.  
  378. (defun buffer-unflag-all-files (flag &optional arg)
  379.   "Remove a specific or all flags from every buffer line.
  380. With an arg, queries for each marked buffer.
  381. Type \\[help-command] at that time for help."
  382.   (interactive "sRemove flag: (default: all flags) \nP")
  383.   (let ((count 0)
  384.     (re (if (zerop (length flag)) dired-re-mark
  385.           (concat "^" (regexp-quote flag)))))
  386.     (save-excursion
  387.       (let (buffer-read-only case-fold-search query
  388.                  (help-form "\
  389. Type SPC or `y' to unflag one buffer, DEL or `n' to skip to next,
  390. `!' to unflag all remaining buffers with no more questions."))
  391.     (goto-char (point-min))
  392.     (while (re-search-forward re nil t)
  393.       (if (or (not arg)
  394.           (dired-query 'query "Unflag buffer `%s' ? "
  395.                    (Buffer-menu-buffer t)))
  396.           (progn (delete-char -1) (insert " ") (setq count (1+ count))))
  397.       (forward-line 1))))
  398.     (message "%s" (format "Flags removed: %d %s" count flag) )))
  399.  
  400. ;; redefines buff-menu.el's version to make a pop-up for deletions
  401. ;; like Dired does
  402.  
  403. (defun Buffer-menu-execute (&optional marked-buffers-instead)
  404.   "Save and/or delete buffers marked with \\[Buffer-menu-save] or \\[Buffer-menu-delete] commands."
  405.   (interactive)
  406.   (if (not marked-buffers-instead)
  407.       (save-excursion
  408.     (goto-char (point-min))
  409.     (while (re-search-forward "^.S" nil t)
  410.       (let ((modp nil))
  411.         (save-excursion
  412.           (set-buffer (Buffer-menu-buffer t))
  413.           (save-buffer)
  414.           (setq modp (buffer-modified-p)))
  415.         (let ((buffer-read-only nil))
  416.           (delete-char -1)
  417.           (insert (if modp ?* ? )))))))
  418.   (save-excursion
  419.     (goto-char (point-min))
  420.     (let ((buffer-menu-buffer (current-buffer))
  421.       (dired-marker-char buffer-delete-marker)
  422.       (buffer-menu-do-deletes nil)
  423.       (buffer-read-only nil))
  424.       (buffer-menu-list (if marked-buffers-instead
  425.                 (char-to-string buffer-marker-char)
  426.               (char-to-string buffer-delete-marker)))
  427.       (if buffer-menu-confirm-deletes
  428.       (if (dired-mark-pop-up
  429.            " *Deletions*" 'deletions buffer-menu-list
  430.            dired-deletion-confirmer
  431.            (format "Delete %s " (buffer-mark-prompt nil buffer-menu-list)))
  432.           (setq buffer-menu-do-deletes t)
  433.         (setq buffer-menu-do-deletes nil))
  434.     (setq buffer-menu-do-deletes t))
  435.       (if buffer-menu-do-deletes
  436.       (while (search-forward
  437.           (if marked-buffers-instead
  438.               (concat "\n" (char-to-string buffer-marker-char))
  439.             (concat "\n" (char-to-string buffer-delete-marker))) nil t)
  440.         (forward-char -1)
  441.         (let ((buf (Buffer-menu-buffer nil)))
  442.           (or (eq buf nil)
  443.           (eq buf buffer-menu-buffer)
  444.           (save-excursion (kill-buffer buf))))
  445.         (if (Buffer-menu-buffer nil)
  446.         (progn (delete-char 1)
  447.                (insert ? ))
  448.           (delete-region (point) (progn (forward-line 1) (point)))
  449.           (forward-char -1)))))))
  450.  
  451. (defun buffer-mark-prompt (arg files)
  452.   ;; Return a string for use in a prompt, either the current file
  453.   ;; name, or the marker and a count of marked files.
  454.   (let ((count (length files)))
  455.     (if (= count 1)
  456.     (car files)
  457.       ;; more than 1 file:
  458.       (if (integerp arg)
  459.       ;; abs(arg) = count
  460.       ;; Perhaps this is nicer, but it also takes more screen space:
  461.       ;;(format "[%s %d files]" (if (> arg 0) "next" "previous")
  462.       ;;                        count)
  463.       (format "[next %d buffers]" arg)
  464.     (format "%c [%d buffers]" dired-marker-char count)))))
  465.  
  466. (defun Buffer-menu-select (&optional arg)
  467.   "Visit all marked buffers at once, and display them simultaneously.
  468. Visit just the buffer the cursor is on if no buffers are marked.
  469. With an arg, visit arg next buffers."
  470.   (interactive "P")
  471.   (simultaneous-find-buffer (buffer-menu-list nil arg)))
  472.  
  473. (defun simultaneous-find-buffer (file-list)
  474.   "Visit all buffers in BUFFER-LIST and display them simultaneously.
  475.  
  476. The current window is split across all buffers in BUFFER-LIST, as evenly
  477. as possible.  Remaining lines go to the bottommost window.
  478. If variable buffer-menu-full-screen is t, then use the whole screen.
  479. The number of buffers that can be displayed this way is restricted by
  480. the height of the current window and the variable `window-min-height'."
  481.   (let ((size (/ (if buffer-menu-full-screen (1- (screen-height))
  482.            (window-height)) (length file-list))))
  483.     (or (<= window-min-height size)
  484.     (error "Too many buffers to visit simultaneously"))
  485.     (if buffer-menu-full-screen (delete-other-windows))
  486.     (switch-to-buffer (car file-list))
  487.     (setq file-list (cdr file-list))
  488.     (while file-list
  489.       ;; Split off vertically a window of the desired size
  490.       ;; The upper window will have SIZE lines.  We select the lower
  491.       ;; (larger) window because we want to split that again.
  492.       (select-window (split-window nil size))
  493.       (switch-to-buffer (car file-list))
  494.       (setq file-list (cdr file-list)))))
  495.  
  496. (defun Buffer-menu-quit ()
  497.   "Bury the current buffer-menu."
  498.   (interactive)
  499.   (bury-buffer)
  500.   (if (not (one-window-p))
  501.       (delete-window)))
  502.  
  503. (defun Buffer-menu-goto-first-buffer ()
  504.   (goto-line 3))
  505.  
  506.  
  507. (defun buffer-copy-buffername-as-kill (&optional arg)
  508.   "Copy names of marked buffers into the kill ring.
  509. The names are separated by a space.
  510. With a prefix arg, use just current buffer.
  511. You can then feed the file name to other commands with \\[yank]."
  512.   (interactive "P")
  513.   (copy-string-as-kill
  514.    (if arg
  515.        (buffer-name (Buffer-menu-buffer t))
  516.      (mapconcat (function identity) (buffer-menu-list) " ")))
  517.   (message "%s" (car kill-ring)))
  518.  
  519. (defun buffer-menu-list (&optional marker-char arg)
  520.   (let ((marker (or marker-char (char-to-string buffer-marker-char)))
  521.     (there-are-some))
  522.     (if arg
  523.     (progn
  524.       (setq buffer-menu-list nil)
  525.       (while (> arg 0)
  526.         (setq buffer-menu-list (cons (buffer-name (Buffer-menu-buffer t))
  527.                      buffer-menu-list))
  528.         (next-line 1)
  529.         (setq arg (1- arg)))
  530.       (setq buffer-menu-list (nreverse buffer-menu-list)))
  531.       (save-excursion
  532.     (goto-char (point-min))
  533.     (if (search-forward (concat "\n" marker) nil t)
  534.         (setq there-are-some t)
  535.       (error "No buffers marked.")))
  536.       (if there-are-some
  537.       (save-excursion
  538.         (setq buffer-menu-list nil)
  539.         (goto-char (point-min))
  540.         (while (search-forward (concat "\n" marker) nil t)
  541.           (setq buffer-menu-list
  542.             (cons (buffer-name (Buffer-menu-buffer t))
  543.               buffer-menu-list)))
  544.         (setq buffer-menu-list (nreverse buffer-menu-list)))
  545.     (setq buffer-menu-list (cons (buffer-name (Buffer-menu-buffer t))
  546.                    nil))))))
  547.  
  548. (defun Buffer-menu-revert ()
  549.   (interactive)
  550.   (let ((opoint (point))
  551.     (buf (Buffer-menu-buffer-no-arg))
  552.     (mark-alist nil)
  553.     case-fold-search
  554.     buffer-read-only)
  555.     (goto-char (point-min))
  556.     (setq mark-alist (buffer-remember-marks (point-min) (point-max)))
  557.     (setq buffer-menu-restricted t)
  558.     (buffer-menu-dired-extended buffer-options t)
  559.     (buffer-mark-remembered mark-alist)
  560.     (run-hooks 'buffer-menu-hook)
  561.     (buffer-goto-buffer buf opoint)
  562.     (beginning-of-line)
  563.     (buffer-menu-move-to-name)))
  564.  
  565. (defun buffer-remember-marks (beg end)
  566.   "Return alist of buffers and their marks, from BEG to END."
  567.   (let (fil chr alist)
  568.     (save-excursion
  569.       (goto-char beg)
  570.       (while (re-search-forward dired-re-mark end t)
  571.     (if (setq fil (buffer-name (Buffer-menu-buffer nil)))
  572.         (setq chr (preceding-char)
  573.           alist (cons (cons fil chr) alist)))))
  574.     alist))
  575.  
  576. (defun buffer-mark-remembered (alist)
  577.   ;; Mark all files remembered in ALIST.
  578.   (let (elt fil chr)
  579.     (while alist
  580.       (setq elt (car alist)
  581.         alist (cdr alist)
  582.         fil (car elt)
  583.         chr (cdr elt))
  584.       (if (buffer-goto-buffer fil)
  585.       (save-excursion
  586.         (beginning-of-line)
  587.         (setq buffer-read-only nil)
  588.         (delete-char 1)
  589.         (insert chr)
  590.         (setq buffer-read-only t))))))
  591.  
  592. (defun buffer-goto-buffer (buf &optional pos)
  593.   (interactive)
  594.   (let ((beg (or pos (point))))
  595.     (goto-char (point-min))
  596.     (if (re-search-forward (concat "\n...." buf) nil t)
  597.     t
  598.       (goto-char beg)
  599.       nil)))
  600.  
  601. (defun buffer-menu-home-to-tilde ()
  602.   "Function to convert the \"home\" to \"~\"."
  603.   (let* ((home (regexp-quote (expand-file-name "~/")))
  604.      (hleng (length home))
  605.      (buffer-read-only nil))
  606.     ;; Unexpand home directory:
  607.     (save-excursion
  608.       (goto-char (point-min))
  609.       (while (re-search-forward home nil t)
  610.     (if (not (= (- (current-column) hleng) 4))
  611.         (replace-match "~/" t t))))))
  612.  
  613. (defun buffer-menu-toggle-sort ()
  614.   "Toggles between sorted and unsorted buffer-menu.  Maintains all other
  615. buffer-menu options."  
  616.   (interactive)
  617.   (let ((opoint (point))
  618.     (buf (Buffer-menu-buffer-no-arg))
  619.     (mark-alist (buffer-remember-marks (point-min) (point-max))))
  620.     (if (string-match "s" buffer-options)
  621.     (setq buffer-options (buffer-menu-translate buffer-options "s" ""))
  622.       (setq buffer-options (concat buffer-options "s")))
  623.     (setq buffer-menu-restricted t)
  624.     (buffer-menu-dired-extended buffer-options t)
  625.     (buffer-mark-remembered mark-alist)
  626.     (buffer-goto-buffer buf)
  627.     (beginning-of-line)))
  628.  
  629. (defun buffer-menu-list-regexp ()
  630.   "Lists only buffer conatining the specified regexp.  Maintains all other
  631. buffer-menu options."
  632.   (interactive)
  633.   (setq buffer-menu-regexp (read-string "Regexp: "))
  634.   (if (string-equal buffer-menu-regexp "")
  635.       (setq buffer-options (buffer-menu-translate buffer-options "r" ""))
  636.     (if (not (string-match "r" buffer-options))
  637.     (setq buffer-options (concat buffer-options "r")))
  638.     (setq buffer-menu-restricted t))
  639.   (buffer-menu-dired-extended buffer-options t))
  640.  
  641. (defun buffer-menu-toggle-direds-or-files ()
  642.   "Cycles listing buffers by direds, files, plain buffers and all buffers."
  643.   (interactive)
  644.   (if (string-match "d" buffer-options)
  645.       (progn
  646.     (setq buffer-options (buffer-menu-translate buffer-options "f" ""))
  647.     (setq buffer-options (buffer-menu-translate buffer-options "n" ""))
  648.     (setq buffer-options (buffer-menu-translate buffer-options "d" "f")))
  649.     (if (string-match "f" buffer-options)
  650.     (progn
  651.       (setq buffer-options (buffer-menu-translate buffer-options "d" ""))
  652.       (setq buffer-options (buffer-menu-translate buffer-options "n" ""))
  653.       (setq buffer-options (buffer-menu-translate buffer-options "f" "n")))
  654.       (if (string-match "n" buffer-options)
  655.       (progn
  656.         (setq buffer-options (buffer-menu-translate buffer-options "d" ""))
  657.         (setq buffer-options (buffer-menu-translate buffer-options "f" ""))
  658.         (setq buffer-options (buffer-menu-translate buffer-options "n" "")))
  659.     (setq buffer-options (concat buffer-options "d")))))
  660.   (setq buffer-menu-restricted t)
  661.   (buffer-menu-dired-extended buffer-options t))
  662.  
  663. (or (equal (assq 'buffer-menu-mode-options minor-mode-alist)
  664.        '(buffer-menu-mode-options buffer-menu-mode-options))
  665.     ;; Test whether this has already been done in case dired is reloaded
  666.     ;; There may be several elements with buffer-menu-mode-options as car.
  667.     (setq minor-mode-alist
  668.       (cons '(buffer-menu-mode-options buffer-menu-mode-options)
  669.         ;; buffer-menu-mode-options is nil outside dired
  670.         minor-mode-alist)))
  671.  
  672. (defun buffer-menu-list-options ()
  673.   (setq buffer-menu-mode-options
  674.     (concat "" 
  675.         (if (string-match "r" buffer-options)
  676.             " regexp")
  677.         (if (string-match "s" buffer-options)
  678.             " sorted")
  679.         (if (string-match "d" buffer-options)
  680.             " direds only")
  681.         (if (string-match "f" buffer-options)
  682.             " files only")
  683.         (if (string-match "n" buffer-options)
  684.             " plain buffers only")))
  685.   ;; update mode line:
  686.   (set-buffer-modified-p (buffer-modified-p)))
  687.  
  688. (defun buffer-menu-translate (string1 string2 string3)
  689.   "Change every occurence in STRING of FSTRING with RSTRING."
  690.   (let ((case-fold-search nil))
  691.     (while (string-match string2 string1)
  692.       (if (not (string-equal string3 ""))
  693.       (aset string1
  694.         (match-beginning 0) (string-to-char string3))
  695.     (setq string1 (concat
  696.                (substring string1 0 (match-beginning 0))
  697.                (substring string1 (match-end 0)))))))
  698.   string1)
  699.  
  700. (defun beginning-of-buffer-menu ()
  701.   "Go to first buffer."
  702.   (interactive)
  703.   (Buffer-menu-goto-first-buffer))
  704.  
  705. (defun end-of-buffer-menu ()
  706.   "Go to last buffer."
  707.   (interactive)
  708.   (goto-char (point-max))
  709.   (forward-line -1)
  710.   (buffer-menu-move-to-name))
  711.  
  712. (defun buffer-menu-rename ()
  713.   "Rename the current buffer and optionally the associated file."
  714.   (interactive)
  715.   (let ((buffer (Buffer-menu-buffer nil))
  716.     new-buffer)
  717.     (setq new-buffer (read-buffer
  718.               (concat "Rename " (buffer-name buffer) " to: ")))
  719.     (if (get-buffer new-buffer)
  720.     (error "Buffer %s already exists" new-buffer)
  721.       (save-excursion 
  722.     (set-buffer buffer)
  723.     (rename-buffer new-buffer))
  724.       (Buffer-menu-revert)
  725.       ;; I don't think it should do anything with filenames, this
  726.       ;; should be done in dired.
  727.       ;; The code below is not tested much!
  728.       (if (and (buffer-file-name buffer)
  729.            (y-or-n-p "Change the filename too? "))
  730.       (let ((new-file (concat (file-name-directory 
  731.                    (buffer-file-name buffer)) new-buffer)))
  732.         (if (file-exists-p new-file)
  733.         (error "File already exists.")
  734.           (save-excursion
  735.         (set-buffer buffer)
  736.         (set-visited-file-name new-file))
  737.           (message ""))))
  738.       )))
  739.  
  740. (defun buffer-menu-next-line (arg)
  741.   "Move down lines then position at buffer name.
  742. Optional prefix ARG says how many lines to move; default is one line."
  743.   (interactive "p")
  744.   (if (> arg 0)
  745.       (while (> arg 0)
  746.     (forward-line 1)
  747.     (if (eobp)
  748.         (goto-line 3)
  749.       (if (< (buffer-menu-cur-line) 3)
  750.           (end-of-buffer-menu)))
  751.     (setq arg (1- arg)))
  752.     (while (< arg 0)
  753.       (forward-line -1)
  754.       (if (eobp)
  755.       (goto-line 3)
  756.     (if (< (buffer-menu-cur-line) 3)
  757.         (end-of-buffer-menu)))
  758.       (setq arg (1+ arg))))
  759.   (buffer-menu-move-to-name))
  760.  
  761. (defun buffer-menu-previous-line (arg)
  762.   "Move up lines then position at buffer name.
  763. Optional prefix ARG says how many lines to move; default is one line."
  764.   (interactive "p")
  765.   (buffer-menu-next-line (- arg)))
  766.  
  767. (defun buffer-jump-back ()
  768.   "Jump back to the buffer menu (*Buffer List*) if it exists, if not
  769. do a buffer-menu."
  770.   (interactive)
  771.   (if (get-buffer "*Buffer List*")
  772.       (switch-to-buffer "*Buffer List*")
  773.     (buffer-menu-dired-extended)))
  774.  
  775. (defun Buffer-menu-mark (arg)
  776.   "Mark next ARG buffers.  Default arg is 1."
  777.   (interactive "p")
  778.   (if (> arg 0) 
  779.       (while (> arg 0)
  780.     (beginning-of-line)
  781.     (if (looking-at " [-M]")
  782.         (ding)
  783.       (let ((buffer-read-only nil))
  784.         (if (not (get-buffer (Buffer-menu-buffer-no-arg)))
  785.         (progn
  786.           (buffer-menu-move-to-name)
  787.           (error (concat
  788.               "Buffer '" (Buffer-menu-buffer-no-arg)
  789.               "' no longer exists."))))
  790.         (delete-char 1)
  791.         (insert buffer-marker-char)
  792.         (buffer-menu-next-line 1)))
  793.     (setq arg (1- arg)))
  794.     (while (< arg 0)
  795.       (beginning-of-line)
  796.       (if (looking-at " [-M]")
  797.       (ding)
  798.     (let ((buffer-read-only nil))
  799.       (delete-char 1)
  800.       (insert buffer-marker-char)
  801.       (buffer-menu-next-line -1)))
  802.       (setq arg (1+ arg)))))
  803.  
  804. (defun Buffer-menu-unmark ()
  805.   "Cancel all requested operations on buffer on this line.  Same as original
  806. except this version positions point on the buffername."
  807.   (interactive)
  808.   (beginning-of-line)
  809.   (if (looking-at " [-M]")
  810.       (ding)
  811.     (let* ((buf (Buffer-menu-buffer t))
  812.        (mod (buffer-modified-p buf))
  813.        (readonly (save-excursion (set-buffer buf) buffer-read-only))
  814.        (buffer-read-only nil))
  815.       (delete-char 3)
  816.       (insert (if readonly (if mod " *%" "  %") (if mod " * " "   ")))))
  817.   (buffer-menu-next-line 1))
  818.  
  819. (defun Buffer-menu-backup-unmark ()
  820.   "Move up and cancel all requested operations on buffer on line above.
  821. Same as original except this version positions point on the buffername."
  822.   (interactive)
  823.   (forward-line -1)
  824.   (Buffer-menu-unmark)
  825.   (forward-line -1)
  826.   (buffer-menu-move-to-name))
  827.  
  828. (defun Buffer-menu-delete (arg)
  829.   "In buffer-menu, flag the current line's buffer for deletion."
  830.   (interactive "p")
  831.   (let ((buffer-marker-char buffer-delete-marker))
  832.     (Buffer-menu-mark arg)))
  833.  
  834. (defun Buffer-menu-display-next-buffer (arg)
  835.   "Move down ARG lines and display the buffer in another window."
  836.   (interactive "p")
  837.   (buffer-menu-next-line arg)
  838.   (Buffer-menu-display-this-buffer))
  839.  
  840. (defun Buffer-menu-display-prev-buffer (arg)
  841.   "Move up ARG lines and display the buffer in another window."
  842.   (interactive "p")
  843.   (Buffer-menu-display-next-buffer (- arg)))
  844.  
  845. (defun Buffer-menu-display-this-buffer ()
  846.   "Display this buffer in another window, keeping cursor in *Buffer list*."
  847.   (interactive)
  848.   (let ((name-buffer (Buffer-menu-buffer-no-arg)))
  849.     (if (get-buffer name-buffer)
  850.     (pop-to-buffer name-buffer)
  851.       (if (y-or-n-p (concat "Buffer '" name-buffer
  852.                 "' no longer exists, create it? "))
  853.       (pop-to-buffer name-buffer)
  854.     (message "Reverting buffer list...")
  855.     (sit-for 1)
  856.     (Buffer-menu-revert))))
  857.     (pop-to-buffer "*Buffer List*"))
  858.   
  859. (defun buffer-menu-cur-line ()
  860.    "Function to return the current line number.    GT"
  861.    (save-excursion
  862.       (beginning-of-line)
  863.       (setq buffer-menu-cur-line (1+ (count-lines 1 (point))))))
  864.  
  865. (defun buffer-menu-do-toggle ()
  866.   "Toggle marks.
  867. That is, currently marked buffers become unmarked and vice versa.
  868. Buffers marked with other flags (such as `D') are not affected."
  869.   (interactive)
  870.   (save-excursion
  871.     (goto-line 3)
  872.     (beginning-of-line)
  873.     (let (buffer-read-only)
  874.       (while (not (eobp))
  875.     (apply 'subst-char-in-region
  876.            (point) (1+ (point))
  877.            (if (eq ?\040 (following-char)) ; SPC
  878.            (list ?\040 buffer-marker-char)
  879.          (list buffer-marker-char ?\040)))
  880.     (forward-line 1)))))
  881.  
  882. (defun buffer-do-delete ()
  883.   "Deletes the buffers marked with the buffer-mark-char.  Interactive if
  884. buffer-menu-confirm-deletes is t."
  885.   (interactive)
  886.   (Buffer-menu-execute t))
  887.  
  888. (define-key global-map "\C-c\C-j" 'buffer-jump-back)
  889.  
  890. (fset 'buffer-regexp-prefix (make-sparse-keymap))
  891. (define-key Buffer-menu-mode-map "r" 'buffer-menu-rename)
  892. (define-key Buffer-menu-mode-map "\e<" 'beginning-of-buffer-menu)
  893. (define-key Buffer-menu-mode-map "\e>" 'end-of-buffer-menu)
  894. (define-key Buffer-menu-mode-map "\e{" 'buffer-menu-prev-marked-buffer)
  895. (define-key Buffer-menu-mode-map "\e}" 'buffer-menu-next-marked-buffer)
  896. (define-key Buffer-menu-mode-map "%" 'buffer-regexp-prefix)
  897. (define-key Buffer-menu-mode-map "%d" 'buffer-flag-regexp-files)
  898. (define-key Buffer-menu-mode-map "%m" 'buffer-mark-files-regexp)
  899. (define-key Buffer-menu-mode-map "\M-\C-?" 'buffer-unflag-all-files)
  900. (define-key Buffer-menu-mode-map "F" 'Buffer-menu-select)
  901. (define-key Buffer-menu-mode-map "q" 'Buffer-menu-quit)
  902. (define-key Buffer-menu-mode-map "g" 'Buffer-menu-revert)
  903. (define-key Buffer-menu-mode-map "w" 'buffer-copy-buffername-as-kill)
  904. (define-key Buffer-menu-mode-map "R" 'buffer-menu-list-regexp)
  905. (define-key Buffer-menu-mode-map "S" 'buffer-menu-toggle-sort)
  906. (define-key Buffer-menu-mode-map "L" 'buffer-menu-toggle-direds-or-files)
  907. (define-key Buffer-menu-mode-map "n" 'buffer-menu-next-line)
  908. (define-key Buffer-menu-mode-map "p" 'buffer-menu-previous-line)
  909. (define-key Buffer-menu-mode-map " " 'buffer-menu-next-line)
  910. (define-key Buffer-menu-mode-map "\C-n" 'buffer-menu-next-line)
  911. (define-key Buffer-menu-mode-map "\C-p" 'buffer-menu-previous-line)
  912. (define-key Buffer-menu-mode-map "N" 'Buffer-menu-display-next-buffer)
  913. (define-key Buffer-menu-mode-map "P" 'Buffer-menu-display-prev-buffer)
  914. (define-key Buffer-menu-mode-map "J" 'Buffer-menu-display-this-buffer)
  915. (define-key Buffer-menu-mode-map "T" 'buffer-menu-do-toggle)
  916. (define-key Buffer-menu-mode-map "X" 'buffer-do-delete)
  917.