;;;; buffer-menu.jl -- interactive buffer manipulation
;;;  Copyright (C) 1994 John Harper <jsh@ukc.ac.uk>

;;; This file is part of Jade.

;;; Jade is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2, or (at your option)
;;; any later version.

;;; Jade is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.

;;; You should have received a copy of the GNU General Public License
;;; along with Jade; see the file COPYING.  If not, write to
;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

(provide 'buffer-menu)


(defvar bm-buffer (make-buffer "*Buffer Menu*"))
(set-buffer-special bm-buffer t)
(set-buffer-read-only bm-buffer t)
(with-buffer bm-buffer
  (setq buffer-record-undo nil))

(defvar bm-keymap (make-keylist))
(bind-keys bm-keymap
  "d" 'bm-toggle-deletion
  "s" 'bm-toggle-save
  "Ctrl-s" 'bm-toggle-save
  "u" 'bm-unmark-line
  "x" 'bm-execute
  "1" 'bm-select-buffer
  "RET" 'bm-select-buffer
  "f" 'bm-select-buffer
  "q" 'bury-buffer
  "~" 'bm-toggle-modified
  "-" 'bm-toggle-read-only
  "%" 'bm-toggle-read-only
  "o" 'bm-other-window-select-buffer
  "Ctrl-f" 'bm-next
  "TAB" 'bm-next
  "Ctrl-b" 'bm-prev
  "Shift-TAB" 'bm-prev
  "Ctrl-l" 'bm-update
  "LMB-Click1" '(goto-char (mouse-pos))
  "LMB-Click2" 'bm-select-buffer)

(defvar bm-pending-deletions '()
  "List of buffers marked for deletion.")

(defvar bm-pending-saves '()
  "List of buffers marked to be saved.")


(defun buffer-menu-mode ()
  "Buffer Menu Mode:\n
This major mode is used in the `*Buffer Menu*' buffer; it provides
interactive commands for manipulating the list of buffers loaded into
the editor.\n
Commands available are,\n
  `d'			Mark buffer for deletion.
  `s', `Ctrl-s'		Mark buffer to be saved.
  `x'			Execute marked saves and deletions.
  `u'			Unmark the current line.
  `1'			Select the current line's buffer in this window.
  `o'			Display the current line's buffer in a different
			window.
  `~'			Toggle the buffer's `modified' flag.
  `%', `-'		Toggle the buffer's read-only status.
  `Ctrl-f', `TAB'	Move forwards through the menu.
  `Ctrl-b', `Shift-TAB' Cycle backwards through the menu.
  `Ctrl-l'		Redraw the menu, incorporating any changes to the
			buffer-list.
  `q'			Quit the buffer menu."
  (when major-mode-kill
    (funcall major-mode-kill))
  (setq major-mode 'buffer-menu-mode
	major-mode-kill 'buffer-menu-kill
	mode-name "Buffer Menu"
	keymap-path (cons 'bm-keymap keymap-path))
  (add-hook 'unbound-key-hook 'bm-unbound-function)
  (eval-hook 'buffer-menu-mode-hook))

(defun buffer-menu-kill ()
  (setq major-mode nil
	major-mode-kill nil
	mode-name nil
	keymap-path (delq 'bm-keymap keymap-path))
  (remove-hook 'unbound-key-hook 'bm-unbound-function))

;;;###autoload
(defun buffer-menu ()
  (interactive)
  (goto-buffer bm-buffer)
  (unless (eq major-mode 'buffer-menu-mode)
    (buffer-menu-mode))
  (bm-list-buffers)
  (goto-char (pos 0 2)))


(defun bm-unbound-function ()
  (error "No command bound to this key!"))

(defun bm-list-buffers ()
  (let
      ((inhibit-read-only t))
    (clear-buffer)
    (insert "   MR\tName\t\tMode\t\tFile\n   --\t----\t\t----\t\t----\n")
    (let
	((list buffer-list)
	 buf)
      (while (setq buf (car list))
	(format bm-buffer "%c%c %c%c\t%s\t"
		(if (memq buf bm-pending-deletions) ?D ?\ )
		(if (memq buf bm-pending-saves) ?S ?\ )
		(if (buffer-modified-p buf) ?+ ?\ )
		(if (buffer-read-only-p buf) ?- ?\ )
		(buffer-name buf))
	(indent-to 24)
	(format bm-buffer "%s%s\t"
		(or (with-buffer buf mode-name) "Generic")
		(or (with-buffer buf minor-mode-names) ""))
	(indent-to 40)
	(format bm-buffer "%s\n" (buffer-file-name buf))
	(setq list (cdr list))))))

(defun bm-get-buffer ()
  (unless (> (pos-line (cursor-pos)) 1)
    ;; on the heading
    (error "Can't work on the heading!"))
  (if (regexp-match-line "^[^\t]+[\t]+([^\t]+)\t")
      (get-buffer (copy-area (match-start 1) (match-end 1)))
    (error "Can't find buffer name")))

(defun bm-find-buffer-line (buf)
  (find-next-regexp (concat "^[^\t]+[\t]+"
			    (regexp-quote (buffer-name buf))
			    "\t")
		    (pos 0 2)))

(defun bm-toggle-deletion ()
  (interactive)
  (let
      ((buf (bm-get-buffer))
       (inhibit-read-only t))
    (if (memq buf bm-pending-deletions)
	(progn
	  (setq bm-pending-deletions (delq buf bm-pending-deletions))
	  (set-char ?\  (pos 0 nil)))
      (setq bm-pending-deletions (cons buf bm-pending-deletions))
      (set-char ?D (pos 0 nil)))
    (bm-next)))

(defun bm-toggle-save ()
  (interactive)
  (let
      ((buf (bm-get-buffer))
       (inhibit-read-only t))
    (if (memq buf bm-pending-saves)
	(progn
	  (setq bm-pending-saves (delq buf bm-pending-saves))
	  (set-char ?\  (pos 1 nil)))
      (setq bm-pending-saves (cons buf bm-pending-saves))
      (set-char ?S (pos 1 nil)))
    (bm-next)))

(defun bm-unmark-line ()
  (interactive)
  (let
      ((buf (bm-get-buffer))
       (inhibit-read-only t))
    (setq bm-pending-saves (delq buf bm-pending-saves)
	  bm-pending-deletions (delq buf bm-pending-deletions))
    (set-char ?\  (pos 0 nil))
    (set-char ?\  (pos 1 nil))
    (bm-next)))

(defun bm-execute ()
  (interactive)
  (let
      ((list bm-pending-saves)
       (inhibit-read-only t)
       buf)
    (setq bm-pending-saves nil)
    (while (setq buf (car list))
      (when (save-file buf)
	(let
	    ((pos (bm-find-buffer-line buf)))
	  (when pos
	    (set-char ?\  (pos 1 (pos-line pos)))
	    (unless (buffer-modified-p buf)
	      (set-char ?\  (pos 3 (pos-line pos)))))))
      (setq list (cdr list)))
    (setq list bm-pending-deletions
	  bm-pending-deletions nil)
    (while (setq buf (car list))
      (let
	  ((pos (bm-find-buffer-line buf)))
	(when (kill-buffer buf)
	  (when pos
	    (delete-area pos (next-line 1 (copy-pos pos))))))
      (setq list (cdr list)))))

(defun bm-select-buffer ()
  (interactive)
  (let
      ((new-buf (bm-get-buffer)))
    (bury-buffer bm-buffer)
    (goto-buffer new-buf)))

(defun bm-other-window-select-buffer ()
  (interactive)
  (let
      ((buf (bm-get-buffer)))
    (in-other-window '(goto-buffer buf))))

(defun bm-toggle-modified ()
  (interactive)
  (let
      ((buf (bm-get-buffer))
       (inhibit-read-only t))
    (if (buffer-modified-p buf)
	(progn
	  (set-buffer-modified buf nil)
	  (set-char ?\  (pos 3 nil)))
      (set-buffer-modified buf t)
      (when (buffer-modified-p buf)
	(set-char ?+ (pos 3 nil)))))
  (bm-next))

(defun bm-toggle-read-only ()
  (interactive)
  (let
      ((buf (bm-get-buffer))
       (inhibit-read-only t))
    (if (buffer-read-only-p buf)
	(progn
	  (set-buffer-read-only buf nil)
	  (set-char ?\  (pos 4 nil)))
      (set-buffer-read-only buf t)
      (set-char ?- (pos 4 nil))))
  (bm-next))

(defun bm-update ()
  (interactive)
  (let
      ((old-buf (bm-get-buffer)))
    (bm-list-buffers)
    (goto-char (or (bm-find-buffer-line old-buf)
		   (pos 0 2)))))

(defun bm-next ()
  (interactive)
  (if (>= (pos-line (cursor-pos)) (- (buffer-length) 2))
      ;; last line
      (goto-glyph (pos nil 2))
    (goto-next-line)))

(defun bm-prev ()
  (interactive)
  (if (<= (pos-line (cursor-pos)) 2)
      ;; first line
      (goto-glyph (pos nil (- (buffer-length) 2)))
    (goto-prev-line)))