home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1993 #1 / NN_1993_1.iso / spool / alt / lucidem / bug / 453 < prev    next >
Encoding:
Text File  |  1993-01-12  |  18.1 KB  |  499 lines
  1. x-gateway: rodan.UU.NET from bug-lucid-emacs to alt.lucid-emacs.bug; Tue, 12 Jan 1993 05:19:55 EST
  2. Date: Tue, 12 Jan 1993 10:17:32 GMT
  3. From: djh@CIS.Prime.COM (David Hughes)
  4. Message-ID: <9301121017.AA07455@CIS.Prime.COM>
  5. Subject: Re: Solution to buff-menu.el bug
  6. Newsgroups: alt.lucid-emacs.bug
  7. Path: sparky!uunet!wendy-fate.uu.net!bug-lucid-emacs
  8. Sender: bug-lucid-emacs-request@lucid.com
  9. Lines: 488
  10.  
  11. Excerpt of message (sent 11 January 1993) by Richard Mlynarik:
  12. > One should immediately discount any elisp code which includes "(require 'cl)"
  13.  
  14. Oh dear, yet another of Richard's famously unhelpful flames...
  15.  
  16. Excerpt of message (sent 11 January 93) by Nicolas Rouquette:
  17. > If I may suggest against requiring the cl library, that'd be better.
  18. > I have had some problems with it when using ilisp
  19. >  and Jaime told me that it is not a great idea to load it.
  20.  
  21. Now that is a good example of tact and diplomacy, which, surprise, surprise,
  22. is much more likely to win friends and influence people...
  23.  
  24. So here is buff-menu.el again minus the (require 'cl) and not using the
  25. 'unless' form.
  26.  
  27. --
  28. Regards, David
  29.  
  30. 8< ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ CUT HERE for file: buff-menu.el
  31. ;; Buffer menu main function and support functions.
  32. ;; Copyright (C) 1985, 1986, 1987, 1992 Free Software Foundation, Inc.
  33.  
  34. ;; This file is part of GNU Emacs.
  35.  
  36. ;; GNU Emacs is free software; you can redistribute it and/or modify
  37. ;; it under the terms of the GNU General Public License as published by
  38. ;; the Free Software Foundation; either version 2, or (at your option)
  39. ;; any later version.
  40.  
  41. ;; GNU Emacs is distributed in the hope that it will be useful,
  42. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  43. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  44. ;; GNU General Public License for more details.
  45.  
  46. ;; You should have received a copy of the GNU General Public License
  47. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  48. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  49.  
  50. ; Put buffer *Buffer List* into proper mode right away
  51. ; so that from now on even list-buffers is enough to get a buffer menu.
  52.  
  53. (defvar Buffer-menu-mode-map nil "")
  54.  
  55. (if Buffer-menu-mode-map
  56.     ()
  57.   (setq Buffer-menu-mode-map (make-keymap))
  58.   (suppress-keymap Buffer-menu-mode-map t)
  59.   (define-key Buffer-menu-mode-map "q" 'Buffer-menu-select)
  60.   (define-key Buffer-menu-mode-map "2" 'Buffer-menu-2-window)
  61.   (define-key Buffer-menu-mode-map "1" 'Buffer-menu-1-window)
  62.   (define-key Buffer-menu-mode-map "f" 'Buffer-menu-this-window)
  63.   (define-key Buffer-menu-mode-map "o" 'Buffer-menu-other-window)
  64.   (define-key Buffer-menu-mode-map "s" 'Buffer-menu-save)
  65.   (define-key Buffer-menu-mode-map "d" 'Buffer-menu-delete)
  66.   (define-key Buffer-menu-mode-map "k" 'Buffer-menu-delete)
  67.   (define-key Buffer-menu-mode-map "\C-d" 'Buffer-menu-delete-backwards)
  68.   (define-key Buffer-menu-mode-map "\C-k" 'Buffer-menu-delete)
  69.   (define-key Buffer-menu-mode-map "x" 'Buffer-menu-execute)
  70.   (define-key Buffer-menu-mode-map " " 'next-line)
  71.   (define-key Buffer-menu-mode-map "\177" 'Buffer-menu-backup-unmark)
  72.   (define-key Buffer-menu-mode-map "~" 'Buffer-menu-not-modified)
  73.   (define-key Buffer-menu-mode-map "?" 'describe-mode)
  74.   (define-key Buffer-menu-mode-map "u" 'Buffer-menu-unmark)
  75.   (define-key Buffer-menu-mode-map "m" 'Buffer-menu-mark)
  76.   (define-key Buffer-menu-mode-map "t" 'Buffer-menu-visit-tags-table)
  77.   (define-key Buffer-menu-mode-map 'button2 'Buffer-menu-mouse-select)
  78.   (define-key Buffer-menu-mode-map 'button3 'Buffer-menu-popup-menu)
  79.   )
  80.  
  81. ;; Buffer Menu mode is suitable only for specially formatted data.
  82. (put 'Buffer-menu-mode 'mode-class 'special)
  83.  
  84. (defun Buffer-menu-mode ()
  85.   "Major mode for editing a list of buffers.
  86. Each line describes one of the buffers in Emacs.
  87. Letters do not insert themselves; instead, they are commands.
  88. m -- mark buffer to be displayed.
  89. q -- select buffer of line point is on.
  90.   Also show buffers marked with m in other windows.
  91. 1 -- select that buffer in full-screen window.
  92. 2 -- select that buffer in one window,
  93.   together with buffer selected before this one in another window.
  94. f -- select that buffer in place of the buffer menu buffer.
  95. o -- select that buffer in another window,
  96.   so the buffer menu buffer remains visible in its window.
  97. t -- visit-tags-table this buffer.
  98. ~ -- clear modified-flag on that buffer.
  99. s -- mark that buffer to be saved, and move down.
  100. d or k -- mark that buffer to be deleted, and move down.
  101. C-d -- mark that buffer to be deleted, and move up.
  102. x -- delete or save marked buffers.
  103. u -- remove all kinds of marks from current line.
  104. Delete -- back up a line and remove marks.
  105.  
  106. Precisely,\\{Buffer-menu-mode-map}"
  107.   (kill-all-local-variables)
  108.   (use-local-map Buffer-menu-mode-map)
  109.   (setq truncate-lines t)
  110.   (setq buffer-read-only t)
  111.   (setq major-mode 'Buffer-menu-mode)
  112.   (setq mode-name "Buffer Menu")
  113.   (require 'mode-motion)
  114.   (setq mode-motion-hook 'mode-motion-highlight-line)
  115.   (run-hooks 'buffer-menu-mode-hook))
  116.  
  117. (defvar Buffer-menu-buffer-column 4)
  118.  
  119. ;; from mly@ai.mit.edu (Richard Mlynarik)
  120. (defun Buffer-menu-buffer (error-if-non-existent-p)
  121.   "Return buffer described by this line of buffer menu."
  122.   (save-excursion
  123.     (beginning-of-line)
  124.     (forward-char Buffer-menu-buffer-column)
  125.     (let* ((start (point))
  126.            (string (if (/= (preceding-char) ?\")
  127.                        ;; End of buffer name marked by tab or a space.
  128.                        (progn (re-search-forward "\t\\| ")
  129.                               (skip-chars-backward " \t")
  130.                               (buffer-substring start (point)))
  131.                        (progn
  132.                          (backward-char 1)
  133.                          (read (current-buffer))))))
  134.       (or (get-buffer string)
  135.       (if error-if-non-existent-p
  136.           (error "No buffer named \"%s\"" string)
  137.         nil)))))
  138.  
  139. (defvar list-buffers-buffer-width 19
  140.   "*Default width allowed for displaying buffer name in buffer menu")
  141.  
  142. (defun list-buffers-header-line ()
  143.   (let ((blank (substring "                                                              "
  144.                           0 (- list-buffers-buffer-width 7))))
  145.     (concat " MR Buffer" blank "Size  Mode         File\n"
  146.             " -- ------" blank "----  ----         ----\n")))
  147.  
  148. (defvar list-buffers-identification 'default-list-buffers-identification
  149.   "String used to identify this buffer, or a function of one argument
  150. to generate such a string.  This variable is always buffer-local.")
  151. (make-variable-buffer-local 'list-buffers-identification)
  152.  
  153. (defun goto-column (column)
  154.   "Move to column COLUMN in current line.
  155. Differs from move-to-column in that it creates or modifies whitespace
  156. if necessary to attain exactly the specified column."
  157.   (interactive "NGoto column: ")
  158.   (move-to-column column)
  159.   (let ((col (current-column)))
  160.     (if (< col column)
  161.         (indent-to column)
  162.       (if (and (/= col column)
  163.                (= (preceding-char) ?\t))
  164.           (let (indent-tabs-mode)
  165.             (delete-char -1)
  166.             (indent-to col)
  167.             (move-to-column column))))))
  168.  
  169. (defun default-list-buffers-identification (output)
  170.   (save-excursion
  171.     (let ((file (or (buffer-file-name (current-buffer))
  172.                     (and (boundp 'list-buffers-directory)
  173.                          list-buffers-directory)))
  174.           (size (buffer-size))
  175.           (mode mode-name)
  176.           p s)
  177.       (set-buffer output)
  178.       (prin1 size)
  179.       (setq p (point))
  180.       ;; right-justify the size
  181.       (goto-column (1+ list-buffers-buffer-width))
  182.       (setq s (- 6 (- p (point))))
  183.       (while (> s 0) ; speed/consing tradeoff...
  184.         (insert ? )
  185.         (setq s (1- s)))
  186.       (end-of-line)
  187.       (indent-to (+ 9 list-buffers-buffer-width) 1)
  188.       (insert mode)
  189.       (if (not file)
  190.           nil
  191.         ;; if the mode-name is really long, clip it for the filename
  192.         (if (> 0 (setq s (- (+ 21 list-buffers-buffer-width) (current-column))))
  193.             (delete-char s))
  194.         (indent-to (+ 22 list-buffers-buffer-width) 1)
  195.         (insert file)))))
  196.  
  197. (defun list-buffers (&optional files-only no-check)
  198.   "Display a list of names of existing buffers.
  199. Inserts it in buffer *Buffer List* and displays that.
  200. Note that buffers with names starting with spaces are omitted.
  201. Non-null optional arg FILES-ONLY means mention only file buffers.
  202. If NO-CHECK is non-nil, then list-buffers does not reset itself
  203. if the maximum buffername length is found to be greater than
  204. the variable list-buffers-buffer-width.
  205.  
  206. The M column contains a * for buffers that are modified.
  207. The R column contains a % for buffers that are read-only."
  208.   (interactive "P")
  209.   (let* (tmpbuf
  210.          (tmpbuflist (if (not no-check) (buffer-list)))
  211.          (elt (if (not no-check) (length tmpbuflist))))
  212.     (if (not no-check)
  213.       (while (> elt 0)
  214.         (setq elt (1- elt)
  215.               tmpbuf (nth elt tmpbuflist))
  216.         (setnth elt tmpbuflist
  217.                 (if (or (buffer-file-name tmpbuf) (null files-only))
  218.                     (length (buffer-name tmpbuf))
  219.                   0))))
  220.     (let* ((current (current-buffer))
  221.            (list-buffers-buffer-width (if no-check
  222.                                           list-buffers-buffer-width
  223.                                         (max list-buffers-buffer-width (+ 3 (apply 'max tmpbuflist)))))
  224.            (col1 (1+ list-buffers-buffer-width))
  225.            output)
  226.       (save-excursion
  227.         (with-output-to-temp-buffer "*Buffer List*"
  228.           (let ((buffers (buffer-list)))
  229.             (setq output standard-output)
  230.             (set-buffer output)
  231.             (Buffer-menu-mode)
  232.             (setq buffer-read-only nil)
  233.             (buffer-flush-undo output)
  234.             (insert (list-buffers-header-line))
  235.             (while buffers
  236.               (let* ((buffer (car buffers))
  237.                      (name (buffer-name buffer))
  238.                      (file (buffer-file-name buffer)))
  239.                 (setq buffers (cdr buffers))
  240.                 (cond ((null name)) ;deleted buffer
  241.                       ((and (/= 0 (length name));don't mention if starts with " "
  242.                             (= (aref name 0) ?\ )))
  243.                       ((and files-only (null file)))
  244.                       (t
  245.                        (set-buffer buffer)
  246.                        (let ((ro buffer-read-only)
  247.                              (id list-buffers-identification))
  248.                          (set-buffer output)
  249.                          (insert (if (eq buffer current)
  250.                                      (progn (setq current (point)) ?\.)
  251.                                    ?\ ))
  252.                          (insert (if (buffer-modified-p buffer)
  253.                                      ?\*
  254.                                    ?\ ))
  255.                          (insert (if ro
  256.                                      ?\%
  257.                                    ?\ ))
  258.                          (if (string-match "[\n\"\\ \t]" name)
  259.                              (let ((print-escape-newlines t))
  260.                                (prin1 name output))
  261.                            (insert ?\  name))
  262.                          (indent-to col1 1)
  263.                          (cond ((stringp id)
  264.                                 (insert id))
  265.                                (id
  266.                                 (set-buffer buffer)
  267.                                 (condition-case e
  268.                                     (funcall id output)
  269.                                   (error
  270.                                    (princ "***" output) (prin1 e output)))
  271.                                 (set-buffer output)
  272.                                 (goto-char (point-max)))))
  273.                        (insert ?\n)))))
  274.             (setq buffer-read-only t))))
  275.       (if (not (bufferp current))
  276.           (save-excursion
  277.             (set-buffer output)
  278.             (goto-char current))))))
  279.  
  280. (defun buffer-menu (arg)
  281.   "Make a menu of buffers so you can save, delete or select them.
  282. With argument, show only buffers that are visiting files.
  283. Type ? after invocation to get help on commands available.
  284. Type q immediately to make the buffer menu go away."
  285.   (interactive "P")
  286.   (list-buffers arg)
  287.   (pop-to-buffer "*Buffer List*")
  288.   (forward-line 2)
  289.   (message
  290.    "Commands: d, s, x; 1, 2, m, u, q; delete; ~;  ? for help."))
  291.  
  292. (defun Buffer-menu-mark ()
  293.   "Mark buffer on this line for being displayed by \\[Buffer-menu-select] command."
  294.   (interactive)
  295.   (beginning-of-line)
  296.   (if (looking-at " [-M]")
  297.       (ding)
  298.     (let ((buffer-read-only nil))
  299.       (delete-char 1)
  300.       (insert ?>)
  301.       (forward-line 1))))
  302.  
  303. (defun Buffer-menu-unmark ()
  304.   "Cancel all requested operations on buffer on this line."
  305.   (interactive)
  306.   (beginning-of-line)
  307.   (if (looking-at " [-M]")
  308.       (ding)
  309.     (let* ((buf (Buffer-menu-buffer t))
  310.        (mod (buffer-modified-p buf))
  311.        (readonly (save-excursion (set-buffer buf) buffer-read-only))
  312.        (buffer-read-only nil))
  313.       (delete-char 3)
  314.       (insert (if readonly (if mod " *%" "  %") (if mod " * " "   ")))))
  315.   (forward-line 1))
  316.  
  317. (defun Buffer-menu-backup-unmark ()
  318.   "Move up and cancel all requested operations on buffer on line above."
  319.   (interactive)
  320.   (forward-line -1)
  321.   (Buffer-menu-unmark)
  322.   (forward-line -1))
  323.  
  324. (defun Buffer-menu-delete ()
  325.   "Mark buffer on this line to be deleted by \\[Buffer-menu-execute] command."
  326.   (interactive)
  327.   (beginning-of-line)
  328.   (if (looking-at " [-M]")        ;header lines
  329.       (ding)
  330.     (let ((buffer-read-only nil))
  331.       (delete-char 1)
  332.       (insert ?D)
  333.       (forward-line 1))))
  334.  
  335. (defun Buffer-menu-delete-backwards ()
  336.   "Mark buffer on this line to be deleted by \\[Buffer-menu-execute] command
  337. and then move up one line"
  338.   (interactive)
  339.   (Buffer-menu-delete)
  340.   (forward-line -2)
  341.   (if (looking-at " [-M]") (forward-line 1)))
  342.  
  343. (defun Buffer-menu-save ()
  344.   "Mark buffer on this line to be saved by \\[Buffer-menu-execute] command."
  345.   (interactive)
  346.   (beginning-of-line)
  347.   (forward-char 1)
  348.   (if (looking-at " [-M]")        ;header lines
  349.       (ding)
  350.     (let ((buffer-read-only nil))
  351.       (delete-char 1)
  352.       (insert ?S)
  353.       (forward-line 1))))
  354.  
  355. (defun Buffer-menu-not-modified ()
  356.   "Mark buffer on this line as unmodified (no changes to save)."
  357.   (interactive)
  358.   (save-excursion
  359.     (set-buffer (Buffer-menu-buffer t))
  360.     (set-buffer-modified-p nil))
  361.   (save-excursion
  362.    (beginning-of-line)
  363.    (forward-char 1)
  364.    (if (looking-at "\\*")
  365.        (let ((buffer-read-only nil))
  366.      (delete-char 1)
  367.      (insert ? )))))
  368.  
  369. (defun Buffer-menu-execute ()
  370.   "Save and/or delete buffers marked with \\[Buffer-menu-save] or \\[Buffer-menu-delete] commands."
  371.   (interactive)
  372.   (save-excursion
  373.     (goto-char (point-min))
  374.     (forward-line 1)
  375.     (while (re-search-forward "^.S" nil t)
  376.       (let ((modp nil))
  377.     (save-excursion
  378.       (set-buffer (Buffer-menu-buffer t))
  379.       (save-buffer)
  380.       (setq modp (buffer-modified-p)))
  381.     (let ((buffer-read-only nil))
  382.       (delete-char -1)
  383.       (insert (if modp ?* ? ))))))
  384.   (save-excursion
  385.     (goto-char (point-min))
  386.     (forward-line 1)
  387.     (let ((buff-menu-buffer (current-buffer))
  388.       (buffer-read-only nil))
  389.       (while (search-forward "\nD" nil t)
  390.     (forward-char -1)
  391.     (let ((buf (Buffer-menu-buffer nil)))
  392.       (or (eq buf nil)
  393.           (eq buf buff-menu-buffer)
  394.           (save-excursion (kill-buffer buf))))
  395.     (if (Buffer-menu-buffer nil)
  396.         (progn (delete-char 1)
  397.            (insert ? ))
  398.       (delete-region (point) (progn (forward-line 1) (point)))
  399.        (forward-char -1))))))
  400.  
  401. (defun Buffer-menu-select ()
  402.   "Select this line's buffer; also display buffers marked with \">\".
  403. You can mark buffers with the \\[Buffer-menu-mark] command."
  404.   (interactive)
  405.   (let ((buff (Buffer-menu-buffer t))
  406.     (menu (current-buffer))          
  407.     (others ())
  408.     tem)
  409.     (goto-char (point-min))
  410.     (while (search-forward "\n>" nil t)
  411.       (setq tem (Buffer-menu-buffer t))
  412.       (let ((buffer-read-only nil))
  413.     (delete-char -1)
  414.     (insert ?\ ))
  415.       (or (eq tem buff) (memq tem others) (setq others (cons tem others))))
  416.     (setq others (nreverse others)
  417.       tem (/ (1- (screen-height)) (1+ (length others))))
  418.     (delete-other-windows)
  419.     (switch-to-buffer buff)
  420.     (or (eq menu buff)
  421.     (bury-buffer menu))
  422.     (while others
  423.       (split-window nil tem)
  424.       (other-window 1)
  425.       (switch-to-buffer (car others))
  426.       (setq others (cdr others)))
  427.     (other-window 1)))            ;back to the beginning!
  428.  
  429. (defun Buffer-menu-visit-tags-table ()
  430.   "Visit the tags table in the buffer on this line.  See `visit-tags-table'."
  431.   (interactive)
  432.   (let ((file (buffer-file-name (Buffer-menu-buffer t))))
  433.     (if file
  434.     (visit-tags-table file)
  435.       (error "Specified buffer has no file"))))
  436.  
  437. (defun Buffer-menu-1-window ()
  438.   "Select this line's buffer, alone, in full screen."
  439.   (interactive)
  440.   (switch-to-buffer (Buffer-menu-buffer t))
  441.   (bury-buffer (other-buffer))
  442.   (delete-other-windows))
  443.  
  444. (defun Buffer-menu-this-window ()
  445.   "Select this line's buffer in this window."
  446.   (interactive)
  447.   (switch-to-buffer (Buffer-menu-buffer t)))
  448.  
  449. (defun Buffer-menu-other-window ()
  450.   "Select this line's buffer in other window, leaving buffer menu visible."
  451.   (interactive)
  452.   (switch-to-buffer-other-window (Buffer-menu-buffer t)))
  453.  
  454. (defun Buffer-menu-2-window ()
  455.   "Select this line's buffer, with previous buffer in second window."
  456.   (interactive)
  457.   (let ((buff (Buffer-menu-buffer t))
  458.     (menu (current-buffer))
  459.     (pop-up-windows t))
  460.     (switch-to-buffer (other-buffer))
  461.     (pop-to-buffer buff)
  462.     (bury-buffer menu)))
  463.  
  464.  
  465. ;;; mouseability
  466.  
  467. (defun Buffer-menu-mouse-select (event)
  468.   (interactive "e")
  469.   (mouse-set-point event)
  470.   (Buffer-menu-select))
  471.  
  472. (defvar Buffer-menu-popup-menu
  473.   '("Buffer Commands"
  474.     ["Select Buffer"            Buffer-menu-select        t]
  475.     ["Select buffer Other Window"    Buffer-menu-other-window    t]
  476.     ["Clear Buffer Modification Flag"    Buffer-menu-not-modified    t]
  477.     "----"
  478.     ["Mark Buffer for Selection"    Buffer-menu-mark        t]
  479.     ["Mark Buffer for Save"        Buffer-menu-save        t]
  480.     ["Mark Buffer for Deletion"        Buffer-menu-delete        t]
  481.     ["Unmark Buffer"            Buffer-menu-unmark        t]
  482.     "----"
  483.     ["Delete/Save Marked Buffers"    Buffer-menu-execute        t]
  484.     ))
  485.  
  486. (defun Buffer-menu-popup-menu (event)
  487.   (interactive "e")
  488.   (mouse-set-point event)
  489.   (beginning-of-line)
  490.   (let ((buffer (Buffer-menu-buffer nil)))
  491.     (if buffer
  492.     (popup-menu
  493.      (nconc (list (car Buffer-menu-popup-menu)
  494.               (concat
  495.                "Commands on buffer \"" (buffer-name buffer) "\":")
  496.               "----")
  497.         (cdr Buffer-menu-popup-menu)))
  498.       (error "no buffer on this line"))))
  499.