home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 8 / FreshFishVol8-CD1.bin / new / util / edit / jade / lisp / buffer-menu.jl < prev    next >
Lisp/Scheme  |  1994-09-20  |  8KB  |  269 lines
  1. ;;;; buffer-menu.jl -- interactive buffer manipulation
  2. ;;;  Copyright (C) 1994 John Harper <jsh@ukc.ac.uk>
  3.  
  4. ;;; This file is part of Jade.
  5.  
  6. ;;; Jade is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 2, or (at your option)
  9. ;;; any later version.
  10.  
  11. ;;; Jade is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;;; GNU General Public License for more details.
  15.  
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with Jade; see the file COPYING.  If not, write to
  18. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. (provide 'buffer-menu)
  21.  
  22.  
  23. (defvar bm-buffer (make-buffer "*Buffer Menu*"))
  24. (set-buffer-special bm-buffer t)
  25. (set-buffer-read-only bm-buffer t)
  26. (with-buffer bm-buffer
  27.   (setq buffer-record-undo nil))
  28.  
  29. (defvar bm-keymap (make-keylist))
  30. (bind-keys bm-keymap
  31.   "d" 'bm-toggle-deletion
  32.   "s" 'bm-toggle-save
  33.   "Ctrl-s" 'bm-toggle-save
  34.   "u" 'bm-unmark-line
  35.   "x" 'bm-execute
  36.   "1" 'bm-select-buffer
  37.   "RET" 'bm-select-buffer
  38.   "f" 'bm-select-buffer
  39.   "q" 'bury-buffer
  40.   "~" 'bm-toggle-modified
  41.   "-" 'bm-toggle-read-only
  42.   "%" 'bm-toggle-read-only
  43.   "o" 'bm-other-window-select-buffer
  44.   "Ctrl-f" 'bm-next
  45.   "TAB" 'bm-next
  46.   "Ctrl-b" 'bm-prev
  47.   "Shift-TAB" 'bm-prev
  48.   "Ctrl-l" 'bm-update
  49.   "LMB-Click1" '(goto-char (mouse-pos))
  50.   "LMB-Click2" 'bm-select-buffer)
  51.  
  52. (defvar bm-pending-deletions '()
  53.   "List of buffers marked for deletion.")
  54.  
  55. (defvar bm-pending-saves '()
  56.   "List of buffers marked to be saved.")
  57.  
  58.  
  59. (defun buffer-menu-mode ()
  60.   "Buffer Menu Mode:\n
  61. This major mode is used in the `*Buffer Menu*' buffer; it provides
  62. interactive commands for manipulating the list of buffers loaded into
  63. the editor.\n
  64. Commands available are,\n
  65.   `d'            Mark buffer for deletion.
  66.   `s', `Ctrl-s'        Mark buffer to be saved.
  67.   `x'            Execute marked saves and deletions.
  68.   `u'            Unmark the current line.
  69.   `1'            Select the current line's buffer in this window.
  70.   `o'            Display the current line's buffer in a different
  71.             window.
  72.   `~'            Toggle the buffer's `modified' flag.
  73.   `%', `-'        Toggle the buffer's read-only status.
  74.   `Ctrl-f', `TAB'    Move forwards through the menu.
  75.   `Ctrl-b', `Shift-TAB' Cycle backwards through the menu.
  76.   `Ctrl-l'        Redraw the menu, incorporating any changes to the
  77.             buffer-list.
  78.   `q'            Quit the buffer menu."
  79.   (when major-mode-kill
  80.     (funcall major-mode-kill))
  81.   (setq major-mode 'buffer-menu-mode
  82.     major-mode-kill 'buffer-menu-kill
  83.     mode-name "Buffer Menu"
  84.     keymap-path (cons 'bm-keymap keymap-path))
  85.   (add-hook 'unbound-key-hook 'bm-unbound-function)
  86.   (eval-hook 'buffer-menu-mode-hook))
  87.  
  88. (defun buffer-menu-kill ()
  89.   (setq major-mode nil
  90.     major-mode-kill nil
  91.     mode-name nil
  92.     keymap-path (delq 'bm-keymap keymap-path))
  93.   (remove-hook 'unbound-key-hook 'bm-unbound-function))
  94.  
  95. ;;;###autoload
  96. (defun buffer-menu ()
  97.   (interactive)
  98.   (goto-buffer bm-buffer)
  99.   (unless (eq major-mode 'buffer-menu-mode)
  100.     (buffer-menu-mode))
  101.   (bm-list-buffers)
  102.   (goto-char (pos 0 2)))
  103.  
  104.  
  105. (defun bm-unbound-function ()
  106.   (error "No command bound to this key!"))
  107.  
  108. (defun bm-list-buffers ()
  109.   (let
  110.       ((inhibit-read-only t))
  111.     (clear-buffer)
  112.     (insert "   MR\tName\t\tMode\t\tFile\n   --\t----\t\t----\t\t----\n")
  113.     (let
  114.     ((list buffer-list)
  115.      buf)
  116.       (while (setq buf (car list))
  117.     (format bm-buffer "%c%c %c%c\t%s\t"
  118.         (if (memq buf bm-pending-deletions) ?D ?\ )
  119.         (if (memq buf bm-pending-saves) ?S ?\ )
  120.         (if (buffer-modified-p buf) ?+ ?\ )
  121.         (if (buffer-read-only-p buf) ?- ?\ )
  122.         (buffer-name buf))
  123.     (indent-to 24)
  124.     (format bm-buffer "%s%s\t"
  125.         (or (with-buffer buf mode-name) "Generic")
  126.         (or (with-buffer buf minor-mode-names) ""))
  127.     (indent-to 40)
  128.     (format bm-buffer "%s\n" (buffer-file-name buf))
  129.     (setq list (cdr list))))))
  130.  
  131. (defun bm-get-buffer ()
  132.   (unless (> (pos-line (cursor-pos)) 1)
  133.     ;; on the heading
  134.     (error "Can't work on the heading!"))
  135.   (if (regexp-match-line "^[^\t]+[\t]+([^\t]+)\t")
  136.       (get-buffer (copy-area (match-start 1) (match-end 1)))
  137.     (error "Can't find buffer name")))
  138.  
  139. (defun bm-find-buffer-line (buf)
  140.   (find-next-regexp (concat "^[^\t]+[\t]+"
  141.                 (regexp-quote (buffer-name buf))
  142.                 "\t")
  143.             (pos 0 2)))
  144.  
  145. (defun bm-toggle-deletion ()
  146.   (interactive)
  147.   (let
  148.       ((buf (bm-get-buffer))
  149.        (inhibit-read-only t))
  150.     (if (memq buf bm-pending-deletions)
  151.     (progn
  152.       (setq bm-pending-deletions (delq buf bm-pending-deletions))
  153.       (set-char ?\  (pos 0 nil)))
  154.       (setq bm-pending-deletions (cons buf bm-pending-deletions))
  155.       (set-char ?D (pos 0 nil)))
  156.     (bm-next)))
  157.  
  158. (defun bm-toggle-save ()
  159.   (interactive)
  160.   (let
  161.       ((buf (bm-get-buffer))
  162.        (inhibit-read-only t))
  163.     (if (memq buf bm-pending-saves)
  164.     (progn
  165.       (setq bm-pending-saves (delq buf bm-pending-saves))
  166.       (set-char ?\  (pos 1 nil)))
  167.       (setq bm-pending-saves (cons buf bm-pending-saves))
  168.       (set-char ?S (pos 1 nil)))
  169.     (bm-next)))
  170.  
  171. (defun bm-unmark-line ()
  172.   (interactive)
  173.   (let
  174.       ((buf (bm-get-buffer))
  175.        (inhibit-read-only t))
  176.     (setq bm-pending-saves (delq buf bm-pending-saves)
  177.       bm-pending-deletions (delq buf bm-pending-deletions))
  178.     (set-char ?\  (pos 0 nil))
  179.     (set-char ?\  (pos 1 nil))
  180.     (bm-next)))
  181.  
  182. (defun bm-execute ()
  183.   (interactive)
  184.   (let
  185.       ((list bm-pending-saves)
  186.        (inhibit-read-only t)
  187.        buf)
  188.     (setq bm-pending-saves nil)
  189.     (while (setq buf (car list))
  190.       (when (save-file buf)
  191.     (let
  192.         ((pos (bm-find-buffer-line buf)))
  193.       (when pos
  194.         (set-char ?\  (pos 1 (pos-line pos)))
  195.         (unless (buffer-modified-p buf)
  196.           (set-char ?\  (pos 3 (pos-line pos)))))))
  197.       (setq list (cdr list)))
  198.     (setq list bm-pending-deletions
  199.       bm-pending-deletions nil)
  200.     (while (setq buf (car list))
  201.       (let
  202.       ((pos (bm-find-buffer-line buf)))
  203.     (when (kill-buffer buf)
  204.       (when pos
  205.         (delete-area pos (next-line 1 (copy-pos pos))))))
  206.       (setq list (cdr list)))))
  207.  
  208. (defun bm-select-buffer ()
  209.   (interactive)
  210.   (let
  211.       ((new-buf (bm-get-buffer)))
  212.     (bury-buffer bm-buffer)
  213.     (goto-buffer new-buf)))
  214.  
  215. (defun bm-other-window-select-buffer ()
  216.   (interactive)
  217.   (let
  218.       ((buf (bm-get-buffer)))
  219.     (in-other-window '(goto-buffer buf))))
  220.  
  221. (defun bm-toggle-modified ()
  222.   (interactive)
  223.   (let
  224.       ((buf (bm-get-buffer))
  225.        (inhibit-read-only t))
  226.     (if (buffer-modified-p buf)
  227.     (progn
  228.       (set-buffer-modified buf nil)
  229.       (set-char ?\  (pos 3 nil)))
  230.       (set-buffer-modified buf t)
  231.       (when (buffer-modified-p buf)
  232.     (set-char ?+ (pos 3 nil)))))
  233.   (bm-next))
  234.  
  235. (defun bm-toggle-read-only ()
  236.   (interactive)
  237.   (let
  238.       ((buf (bm-get-buffer))
  239.        (inhibit-read-only t))
  240.     (if (buffer-read-only-p buf)
  241.     (progn
  242.       (set-buffer-read-only buf nil)
  243.       (set-char ?\  (pos 4 nil)))
  244.       (set-buffer-read-only buf t)
  245.       (set-char ?- (pos 4 nil))))
  246.   (bm-next))
  247.  
  248. (defun bm-update ()
  249.   (interactive)
  250.   (let
  251.       ((old-buf (bm-get-buffer)))
  252.     (bm-list-buffers)
  253.     (goto-char (or (bm-find-buffer-line old-buf)
  254.            (pos 0 2)))))
  255.  
  256. (defun bm-next ()
  257.   (interactive)
  258.   (if (>= (pos-line (cursor-pos)) (- (buffer-length) 2))
  259.       ;; last line
  260.       (goto-glyph (pos nil 2))
  261.     (goto-next-line)))
  262.  
  263. (defun bm-prev ()
  264.   (interactive)
  265.   (if (<= (pos-line (cursor-pos)) 2)
  266.       ;; first line
  267.       (goto-glyph (pos nil (- (buffer-length) 2)))
  268.     (goto-prev-line)))
  269.