X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/56df6a3f7f01e65eee108c2b61cb27030cde7e35..ae5a0dd403ca1ca8d4b8d100c8d92ba3eea04695:/lisp/menu-bar.el diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el index 8b33d7d08c..41bc628c89 100644 --- a/lisp/menu-bar.el +++ b/lisp/menu-bar.el @@ -1,10 +1,10 @@ ;;; menu-bar.el --- define a default menu bar. +;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc. + ;; Author: RMS ;; Keywords: internal -;; Copyright (C) 1993, 1994 Free Software Foundation, Inc. - ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify @@ -18,83 +18,262 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;; Avishai Yacobi suggested some menu rearrangements. ;;; Code: +;;; User options: + +(defcustom buffers-menu-max-size 10 + "*Maximum number of entries which may appear on the Buffers menu. +If this is 10, then only the ten most-recently-selected buffers are shown. +If this is nil, then all buffers are shown. +A large number or nil slows down menu responsiveness." + :type '(choice integer + (const :tag "All" nil)) + :group 'mouse) + ;; Don't clobber an existing menu-bar keymap, to preserve any menu-bar key ;; definitions made in loaddefs.el. (or (lookup-key global-map [menu-bar]) (define-key global-map [menu-bar] (make-sparse-keymap "menu-bar"))) (defvar menu-bar-help-menu (make-sparse-keymap "Help")) -;; Put Help item last. -(setq menu-bar-final-items '(help)) -(define-key global-map [menu-bar help] (cons "Help" menu-bar-help-menu)) + +;; Force Help item to come last, after the major mode's own items. +;; The symbol used to be called `help', but that gets confused with the +;; help key. +(setq menu-bar-final-items '(help-menu)) + +(define-key global-map [menu-bar help-menu] (cons "Help" menu-bar-help-menu)) +(defvar menu-bar-search-menu (make-sparse-keymap "Search")) +(define-key global-map [menu-bar search] (cons "Search" menu-bar-search-menu)) (defvar menu-bar-edit-menu (make-sparse-keymap "Edit")) (define-key global-map [menu-bar edit] (cons "Edit" menu-bar-edit-menu)) -(defvar menu-bar-file-menu (make-sparse-keymap "File")) -(define-key global-map [menu-bar file] (cons "File" menu-bar-file-menu)) +(defvar menu-bar-tools-menu (make-sparse-keymap "Tools")) +(define-key global-map [menu-bar tools] (cons "Tools" menu-bar-tools-menu)) +(defvar menu-bar-files-menu (make-sparse-keymap "Files")) +(define-key global-map [menu-bar files] (cons "Files" menu-bar-files-menu)) -(define-key menu-bar-file-menu [exit-emacs] - '("Exit Emacs" . save-buffers-kill-emacs)) -(define-key menu-bar-file-menu [kill-buffer] - '("Kill Buffer" . kill-this-buffer)) -(define-key menu-bar-file-menu [delete-frame] '("Delete Frame" . delete-frame)) -(define-key menu-bar-file-menu [epatch] +;; This alias is for compatibility with 19.28 and before. +(defvar menu-bar-file-menu menu-bar-files-menu) + +(defvar vc-menu-map (make-sparse-keymap "Version Control")) + +(define-key menu-bar-tools-menu [gdb] '("Debugger..." . gdb)) +(define-key menu-bar-tools-menu [compile] '("Compile..." . compile)) +(define-key menu-bar-tools-menu [grep] '("Search Files..." . grep)) + +(define-key menu-bar-tools-menu [separator-1] + '("--")) + +(define-key menu-bar-tools-menu [calendar] '("Display Calendar" . calendar)) +(define-key menu-bar-tools-menu [compose-mail] '("Send Mail" . compose-mail)) +(define-key menu-bar-tools-menu [rmail] '("Read Mail" . rmail)) +(define-key menu-bar-tools-menu [gnus] '("Read Net News" . gnus)) + +(define-key menu-bar-tools-menu [separator-vc] + '("--")) + +(define-key menu-bar-tools-menu [vc] + (cons "Version Control" vc-menu-map)) + +(define-key menu-bar-tools-menu [separator-compare] + '("--")) + +(define-key menu-bar-tools-menu [epatch] '("Apply Patch" . menu-bar-epatch-menu)) -(define-key menu-bar-file-menu [ediff] - '("Compare Files" . menu-bar-ediff-menu)) -(define-key menu-bar-file-menu [emerge] '("Emerge" . menu-bar-emerge-menu)) -(define-key menu-bar-file-menu [calendar] '("Calendar" . calendar)) -(define-key menu-bar-file-menu [rmail] '("Read Mail" . rmail)) -(define-key menu-bar-file-menu [gnus] '("Read Net News" . gnus)) -(define-key menu-bar-file-menu [bookmark] - '("Bookmarks" . menu-bar-bookmark-map)) -(define-key menu-bar-file-menu [print-buffer] '("Print Buffer" . print-buffer)) -(define-key menu-bar-file-menu [revert-buffer] +(define-key menu-bar-tools-menu [ediff-merge] + '("Merge" . menu-bar-ediff-merge-menu)) +(define-key menu-bar-tools-menu [compare] + '("Compare" . menu-bar-ediff-menu)) + +(define-key menu-bar-tools-menu [separator-print] + '("--")) + +(put 'print-region 'menu-enable 'mark-active) +(put 'ps-print-region-with-faces 'menu-enable 'mark-active) + +(define-key menu-bar-tools-menu [ps-print-region] + '("Postscript Print Region" . ps-print-region-with-faces)) +(define-key menu-bar-tools-menu [ps-print-buffer] + '("Postscript Print Buffer" . ps-print-buffer-with-faces)) +(define-key menu-bar-tools-menu [print-region] + '("Print Region" . print-region)) +(define-key menu-bar-tools-menu [print-buffer] + '("Print Buffer" . print-buffer)) + +(define-key menu-bar-files-menu [exit-emacs] + '("Exit Emacs" . save-buffers-kill-emacs)) + +(define-key menu-bar-files-menu [separator-exit] + '("--")) + +(define-key menu-bar-files-menu [one-window] + '("One Window" . delete-other-windows)) + +(define-key menu-bar-files-menu [split-window] + '("Split Window" . split-window-vertically)) + +(if (fboundp 'delete-frame) + (progn + ;; Don't use delete-frame as event name + ;; because that is a special event. + (define-key menu-bar-files-menu [delete-this-frame] + '("Delete Frame" . delete-frame)) + (define-key menu-bar-files-menu [make-frame-on-display] + '("Open New Display..." . make-frame-on-display)) + (define-key menu-bar-files-menu [make-frame] + '("Make New Frame" . make-frame)))) + +(define-key menu-bar-files-menu [separator-buffers] + '("--")) + +(define-key menu-bar-files-menu [kill-buffer] + '("Kill Current Buffer" . kill-this-buffer)) +(define-key menu-bar-files-menu [insert-file] + '("Insert File..." . insert-file)) +(define-key menu-bar-files-menu [revert-buffer] '("Revert Buffer" . revert-buffer)) -(define-key menu-bar-file-menu [write-file] +(define-key menu-bar-files-menu [write-file] '("Save Buffer As..." . write-file)) -(define-key menu-bar-file-menu [save-buffer] '("Save Buffer" . save-buffer)) -(define-key menu-bar-file-menu [dired] '("Open Directory..." . dired)) -(define-key menu-bar-file-menu [open-file] '("Open File..." . find-file)) -(define-key menu-bar-file-menu [make-frame] '("Make New Frame" . make-frame)) +(define-key menu-bar-files-menu [save-buffer] '("Save Buffer" . save-buffer)) +(define-key menu-bar-files-menu [dired] '("Open Directory..." . dired)) +(define-key menu-bar-files-menu [open-file] '("Open File..." . find-file)) + + +(defun nonincremental-search-forward (string) + "Read a string and search for it nonincrementally." + (interactive "sSearch for string: ") + (if (equal string "") + (search-forward (car search-ring)) + (isearch-update-ring string nil) + (search-forward string))) + +(defun nonincremental-search-backward (string) + "Read a string and search backward for it nonincrementally." + (interactive "sSearch for string: ") + (if (equal string "") + (search-backward (car search-ring)) + (isearch-update-ring string nil) + (search-backward string))) + +(defun nonincremental-re-search-forward (string) + "Read a regular expression and search for it nonincrementally." + (interactive "sSearch for regexp: ") + (if (equal string "") + (re-search-forward (car regexp-search-ring)) + (isearch-update-ring string t) + (re-search-forward string))) + +(defun nonincremental-re-search-backward (string) + "Read a regular expression and search backward for it nonincrementally." + (interactive "sSearch for regexp: ") + (if (equal string "") + (re-search-backward (car regexp-search-ring)) + (isearch-update-ring string t) + (re-search-backward string))) + +(defun nonincremental-repeat-search-forward () + "Search forward for the previous search string." + (interactive) + (search-forward (car search-ring))) + +(defun nonincremental-repeat-search-backward () + "Search backward for the previous search string." + (interactive) + (search-backward (car search-ring))) + +(defun nonincremental-repeat-re-search-forward () + "Search forward for the previous regular expression." + (interactive) + (re-search-forward (car regexp-search-ring))) -(define-key menu-bar-edit-menu [spell] '("Spell" . ispell-menu-map)) +(defun nonincremental-repeat-re-search-backward () + "Search backward for the previous regular expression." + (interactive) + (re-search-backward (car regexp-search-ring))) + +(define-key menu-bar-search-menu [query-replace-regexp] + '("Query Replace Regexp..." . query-replace-regexp)) +(define-key menu-bar-search-menu [query-replace] + '("Query Replace..." . query-replace)) +(define-key menu-bar-search-menu [find-tag] + '("Find Tag..." . find-tag)) +(define-key menu-bar-search-menu [bookmark] + '("Bookmarks" . menu-bar-bookmark-map)) + +(define-key menu-bar-search-menu [separator-search] + '("--")) + +(define-key menu-bar-search-menu [repeat-regexp-back] + '("Repeat Regexp Backwards" . nonincremental-repeat-re-search-backward)) +(define-key menu-bar-search-menu [repeat-search-back] + '("Repeat Backwards" . nonincremental-repeat-search-backward)) +(define-key menu-bar-search-menu [repeat-regexp-fwd] + '("Repeat Regexp" . nonincremental-repeat-re-search-forward)) +(define-key menu-bar-search-menu [repeat-search-fwd] + '("Repeat Search" . nonincremental-repeat-search-forward)) + +(define-key menu-bar-search-menu [separator-repeat] + '("--")) + +(define-key menu-bar-search-menu [re-search-backward] + '("Regexp Search Backwards..." . nonincremental-re-search-backward)) +(define-key menu-bar-search-menu [search-backward] + '("Search Backwards..." . nonincremental-search-backward)) +(define-key menu-bar-search-menu [re-search-forward] + '("Regexp Search..." . nonincremental-re-search-forward)) +(define-key menu-bar-search-menu [search-forward] + '("Search..." . nonincremental-search-forward)) + +(if (fboundp 'start-process) + (define-key menu-bar-edit-menu [spell] '("Spell" . ispell-menu-map))) (define-key menu-bar-edit-menu [fill] '("Fill" . fill-region)) +(define-key menu-bar-edit-menu [props] '("Text Properties" . facemenu-menu)) + +(define-key menu-bar-edit-menu [separator-edit] + '("--")) + (define-key menu-bar-edit-menu [clear] '("Clear" . delete-region)) -(define-key menu-bar-edit-menu [query-replace] - '("Query Replace" . query-replace)) -(define-key menu-bar-edit-menu [re-search-back] - '("Regexp Search Backwards" . re-search-backward)) -(define-key menu-bar-edit-menu [search-back] - '("Search Backwards" . search-backward)) -(define-key menu-bar-edit-menu [re-search-fwd] - '("Regexp Search" . re-search-forward)) -(define-key menu-bar-edit-menu [search-fwd] - '("Search" . search-forward)) -(define-key menu-bar-edit-menu [choose-next-paste] - '("Choose Next Paste >" . mouse-menu-choose-yank)) -(define-key menu-bar-edit-menu [paste] '("Paste" . yank)) -(define-key menu-bar-edit-menu [copy] '("Copy" . kill-ring-save)) + +(define-key menu-bar-edit-menu [paste] '("Paste Most Recent" . yank)) + +(defvar yank-menu (cons "Select Yank" nil)) +(fset 'yank-menu (cons 'keymap yank-menu)) +(define-key menu-bar-edit-menu [select-paste] '("Select and Paste" . yank-menu)) +(define-key menu-bar-edit-menu [copy] '("Copy" . menu-bar-kill-ring-save)) (define-key menu-bar-edit-menu [cut] '("Cut" . kill-region)) (define-key menu-bar-edit-menu [undo] '("Undo" . undo)) -(put 'fill-region 'menu-enable 'mark-active) -(put 'kill-region 'menu-enable 'mark-active) -(put 'kill-ring-save 'menu-enable 'mark-active) -(put 'yank 'menu-enable '(x-selection-exists-p)) -(put 'delete-region 'menu-enable 'mark-active) -(put 'undo 'menu-enable '(if (eq last-command 'undo) - pending-undo-list - (consp buffer-undo-list))) -(put 'query-replace 'menu-enable (not buffer-read-only)) +(defun menu-bar-kill-ring-save (beg end) + (interactive "r") + (if (mouse-region-match) + (message "Select a region with the mouse does `copy' automatically") + (kill-ring-save beg end))) + +(put 'fill-region 'menu-enable '(and mark-active (not buffer-read-only))) +(put 'kill-region 'menu-enable '(and mark-active (not buffer-read-only))) +(put 'menu-bar-kill-ring-save 'menu-enable 'mark-active) +(put 'yank 'menu-enable '(and (x-selection-exists-p) (not buffer-read-only))) +(put 'yank-menu 'menu-enable '(and (cdr yank-menu) (not buffer-read-only))) +(put 'delete-region 'menu-enable '(and mark-active + (not buffer-read-only) + (not (mouse-region-match)))) +(put 'undo 'menu-enable '(and (not buffer-read-only) + (if (eq last-command 'undo) + pending-undo-list + (consp buffer-undo-list)))) +(put 'query-replace 'menu-enable '(not buffer-read-only)) +(put 'query-replace-regexp 'menu-enable '(not buffer-read-only)) (autoload 'ispell-menu-map "ispell" nil t 'keymap) ;; These are alternative definitions for the cut, paste and copy -;; menu items. Use them if your system expects these to use the clipboard +;; menu items. Use them if your system expects these to use the clipboard. (put 'clipboard-kill-region 'menu-enable 'mark-active) (put 'clipboard-kill-ring-save 'menu-enable 'mark-active) @@ -120,7 +299,8 @@ (kill-region beg end))) (defun menu-bar-enable-clipboard () - "Make the menu bar CUT, PASTE and COPY items use the clipboard." + "Make CUT, PASTE and COPY (keys and menu bar items) use the clipboard. +Do the same for the keys of the same name." (interactive) ;; We can't use constant list structure here because it becomes pure, ;; and because it gets modified with cache data. @@ -129,20 +309,44 @@ (define-key menu-bar-edit-menu [copy] (cons "Copy" 'clipboard-kill-ring-save)) (define-key menu-bar-edit-menu [cut] - (cons "Cut" 'clipboard-kill-region))) - -;; Sun expects these commands on these keys, so why not? -(define-key global-map [f20] 'clipboard-kill-region) -(define-key global-map [f16] 'clipboard-kill-ring-save) -(define-key global-map [f18] 'clipboard-yank) + (cons "Cut" 'clipboard-kill-region)) + + (define-key global-map [f20] 'clipboard-kill-region) + (define-key global-map [f16] 'clipboard-kill-ring-save) + (define-key global-map [f18] 'clipboard-yank) + ;; X11R6 versions + (define-key global-map [cut] 'clipboard-kill-region) + (define-key global-map [copy] 'clipboard-kill-ring-save) + (define-key global-map [paste] 'clipboard-yank)) + +;;; Menu support + +(defvar menu-bar-custom-menu (make-sparse-keymap "Customize")) + +(define-key menu-bar-custom-menu [custom-menu-update] + '("Update This Menu" . custom-menu-update)) +(define-key menu-bar-custom-menu [customize-apropos] + '("Apropos..." . customize-apropos)) +(define-key menu-bar-custom-menu [customize-group] + '("Specific Group..." . customize-group)) +(define-key menu-bar-custom-menu [customize-face] + '("Specific Face..." . customize-face)) +(define-key menu-bar-custom-menu [customize-variable] + '("Specific Variable..." . customize-variable)) +(define-key menu-bar-custom-menu [customize] + '("Browse Hierarchy of User Options" . customize)) + (define-key menu-bar-help-menu [emacs-version] '("Show Version" . emacs-version)) (define-key menu-bar-help-menu [report-emacs-bug] - '("Send Bug Report" . report-emacs-bug)) + '("Send Bug Report..." . report-emacs-bug)) +(define-key menu-bar-help-menu [finder-by-keyword] + '("Find Lisp Packages..." . finder-by-keyword)) (define-key menu-bar-help-menu [emacs-tutorial] '("Emacs Tutorial" . help-with-tutorial)) -(define-key menu-bar-help-menu [man] '("Man..." . manual-entry)) +(define-key menu-bar-help-menu [man] + '("Man..." . manual-entry)) (define-key menu-bar-help-menu [describe-variable] '("Describe Variable..." . describe-variable)) (define-key menu-bar-help-menu [describe-function] @@ -155,9 +359,12 @@ '("Command Apropos..." . command-apropos)) (define-key menu-bar-help-menu [describe-mode] '("Describe Mode" . describe-mode)) -(define-key menu-bar-help-menu [info] '("Info" . info)) - +(define-key menu-bar-help-menu [info] '("Browse Manuals" . info)) +(define-key menu-bar-help-menu [emacs-faq] '("Emacs FAQ" . view-emacs-FAQ)) (define-key menu-bar-help-menu [emacs-news] '("Emacs News" . view-emacs-news)) +(define-key menu-bar-help-menu [customize-menu] + (cons "Customize" menu-bar-custom-menu)) + (defun kill-this-buffer () ; for the menubar "Kills the current buffer." (interactive) @@ -170,24 +377,46 @@ (or (string-match "^ " (buffer-name (car buffers))) (setq count (1+ count))) (setq buffers (cdr buffers))) - (> count 1))) + (and (not (window-minibuffer-p (frame-selected-window menu-updating-frame))) + (> count 1)))) + +(put 'kill-this-buffer 'menu-enable '(kill-this-buffer-enabled-p)) + +(put 'save-buffer 'menu-enable + '(and (buffer-modified-p) + (not (window-minibuffer-p (frame-selected-window menu-updating-frame))))) + +(put 'write-file 'menu-enable + '(not (window-minibuffer-p (frame-selected-window menu-updating-frame)))) + +(put 'find-file 'menu-enable + '(not (window-minibuffer-p (frame-selected-window menu-updating-frame)))) + +(put 'dired 'menu-enable + '(not (window-minibuffer-p (frame-selected-window menu-updating-frame)))) + +(put 'insert-file 'menu-enable + '(not (window-minibuffer-p (frame-selected-window menu-updating-frame)))) -(put 'save-buffer 'menu-enable '(buffer-modified-p)) (put 'revert-buffer 'menu-enable '(or revert-buffer-function revert-buffer-insert-file-contents-function (and (buffer-file-name) (or (buffer-modified-p) (not (verify-visited-file-modtime (current-buffer))))))) + ;; Permit deleting frame if it would leave a visible or iconified frame. (put 'delete-frame 'menu-enable - '(let ((frames (frame-list)) - (count 0)) - (while frames - (if (cdr (assq 'visibility (frame-parameters (car frames)))) - (setq count (1+ count))) - (setq frames (cdr frames))) - (> count 1))) -(put 'kill-this-buffer 'menu-enable '(kill-this-buffer-enabled-p)) + '(delete-frame-enabled-p)) + +(defun delete-frame-enabled-p () + "Return non-nil if `delete-frame' should be enabled in the menu bar." + (let ((frames (frame-list)) + (count 0)) + (while frames + (if (frame-visible-p (car frames)) + (setq count (1+ count))) + (setq frames (cdr frames))) + (> count 1))) (put 'advertised-undo 'menu-enable '(and (not (eq t buffer-undo-list)) @@ -196,58 +425,51 @@ pending-undo-list) buffer-undo-list))) -(defvar yank-menu-length 100 - "*Maximum length of an item in the menu for \ -\\[mouse-menu-choose-yank].") - -(defun mouse-menu-choose-yank (event) - "Pop up a menu of the kill-ring for selection with the mouse. -The kill-ring-yank-pointer is moved to the selected element. -A subsequent \\[yank] yanks the choice just selected." - (interactive "e") - (let* ((count 0) - (menu (mapcar (lambda (string) - (if (> (length string) yank-menu-length) - (setq string (substring string - 0 yank-menu-length))) - (prog1 (cons string count) - (setq count (1+ count)))) - kill-ring)) - (arg (x-popup-menu event - (list "Yank Menu" - (cons "Choose Next Yank" menu))))) - ;; A mouse click outside the menu returns nil. - ;; Avoid a confusing error from passing nil to rotate-yank-pointer. - ;; XXX should this perhaps do something other than simply return? -rm - (if arg +(defcustom yank-menu-length 20 + "*Maximum length to display in the yank-menu." + :type 'integer + :group 'mouse) + +(defun menu-bar-update-yank-menu (string old) + (let ((front (car (cdr yank-menu))) + (menu-string (if (<= (length string) yank-menu-length) + string + (concat + (substring string 0 (/ yank-menu-length 2)) + "..." + (substring string (- (/ yank-menu-length 2))))))) + ;; Don't let the menu string be all dashes + ;; because that has a special meaning in a menu. + (if (string-match "\\`-+\\'" menu-string) + (setq menu-string (concat menu-string " "))) + ;; If we're supposed to be extending an existing string, and that + ;; string really is at the front of the menu, then update it in place. + (if (and old (or (eq old (car front)) + (string= old (car front)))) (progn - ;; We don't use `rotate-yank-pointer' because we want to move - ;; relative to the beginning of kill-ring, not the current - ;; position. Also, that would ask for any new X selection and - ;; thus change the list of items the user just chose from, which - ;; would be highly confusing. - (setq kill-ring-yank-pointer (nthcdr arg kill-ring)) - (if (interactive-p) - (message "The next yank will insert the selected text.") - (current-kill 0)))))) -(put 'mouse-menu-choose-yank 'menu-enable 'kill-ring) + (setcar front string) + (setcar (cdr front) menu-string)) + (setcdr yank-menu + (cons + (cons string (cons menu-string 'menu-bar-select-yank)) + (cdr yank-menu))))) + (if (> (length (cdr yank-menu)) kill-ring-max) + (setcdr (nthcdr kill-ring-max yank-menu) nil))) + +(defun menu-bar-select-yank () + (interactive "*") + (push-mark (point)) + (insert last-command-event)) -(define-key global-map [menu-bar buffer] '("Buffers" . menu-bar-buffers)) - -(defalias 'menu-bar-buffers (make-sparse-keymap "Buffers")) - -(defvar complex-buffers-menu-p nil - "*Non-nil says, offer a choice of actions after you pick a buffer. -This applies to the Buffers menu from the menu bar.") - -(defvar buffers-menu-max-size 10 - "*Maximum number of entries which may appear on the Buffers menu. -If this is 10, then only the ten most-recently-selected buffers are shown. -If this is nil, then all buffers are shown. -A large number or nil slows down menu responsiveness.") +;; This definition is just to show what this looks like. +;; It gets overridden below when menu-bar-update-buffers is called. +(define-key global-map [menu-bar buffer] + (cons "Buffers" (make-sparse-keymap "Buffers"))) (defvar list-buffers-directory nil) +(defvar menu-bar-update-buffers-maxbuf) + (defun menu-bar-select-buffer () (interactive) (switch-to-buffer last-command-event)) @@ -258,111 +480,148 @@ A large number or nil slows down menu responsiveness.") (raise-frame last-command-event) (select-frame last-command-event)) -(defvar menu-bar-update-buffers-last-buffers nil) -(defvar menu-bar-update-buffers-last-frames nil) +(defun menu-bar-update-buffers-1 (elt) + (cons (format + (format "%%%ds %%s%%s %%s" menu-bar-update-buffers-maxbuf) + (cdr elt) + (if (buffer-modified-p (car elt)) + "*" " ") + (save-excursion + (set-buffer (car elt)) + (if buffer-read-only "%" " ")) + (let ((file + (or (buffer-file-name (car elt)) + (save-excursion + (set-buffer (car elt)) + list-buffers-directory) + ""))) + (setq file (or (file-name-directory file) + "")) + (if (> (length file) 20) + (setq file (concat "..." (substring file -17)))) + file)) + (car elt))) + +(defvar menu-bar-buffers-menu-list-buffers-entry nil) (defun menu-bar-update-buffers () - (let ((buffers (buffer-list)) - (frames (frame-list)) - buffers-menu frames-menu) - (if (and (equal buffers menu-bar-update-buffers-last-buffers) - (equal frames menu-bar-update-buffers-last-frames)) - nil - (setq menu-bar-update-buffers-last-buffers buffers) - (setq menu-bar-update-buffers-last-frames frames) - ;; If requested, list only the N most recently selected buffers. - (if (and (integerp buffers-menu-max-size) - (> buffers-menu-max-size 1)) - (if (> (length buffers) buffers-menu-max-size) - (setcdr (nthcdr buffers-menu-max-size buffers) nil))) - - ;; Make the menu of buffers proper. - (setq buffers-menu - (cons "Select Buffer" - (let ((tail buffers) - (maxbuf 0) - (maxlen 0) - alist - head) - (while tail - (or (eq ?\ (aref (buffer-name (car tail)) 0)) - (setq maxbuf - (max maxbuf - (length (buffer-name (car tail)))))) - (setq tail (cdr tail))) - (setq tail buffers) - (while tail - (let ((elt (car tail))) - (or (eq ?\ (aref (buffer-name elt) 0)) - (setq alist (cons - (cons - (format - (format "%%%ds %%s%%s %%s" - maxbuf) - (buffer-name elt) - (if (buffer-modified-p elt) - "*" " ") - (save-excursion - (set-buffer elt) - (if buffer-read-only "%" " ")) - (or (buffer-file-name elt) - (save-excursion - (set-buffer elt) - list-buffers-directory) - "")) - elt) - alist))) - (and alist (> (length (car (car alist))) maxlen) - (setq maxlen (length (car (car alist)))))) - (setq tail (cdr tail))) - (setq alist (nreverse alist)) - (nconc (mapcar '(lambda (pair) - ;; This is somewhat risque, to use - ;; the buffer name itself as the event type - ;; to define, but it works. - ;; It would not work to use the buffer - ;; since a buffer as an event has its - ;; own meaning. - (nconc (list (buffer-name (cdr pair)) - (car pair) - (cons nil nil)) - 'menu-bar-select-buffer)) - alist) - (list (cons 'list-buffers - (cons - (concat (make-string (max (- (/ maxlen - 2) - 8) - 0) ?\ ) - "List All Buffers") - 'list-buffers))))))) - - - ;; Make a Frames menu if we have more than one frame. - (if (cdr frames) - (setq frames-menu - (cons "Select Frame" - (mapcar '(lambda (frame) - (nconc (list frame - (cdr (assq 'name - (frame-parameters frame))) - (cons nil nil)) - 'menu-bar-select-frame)) - frames)))) - (if buffers-menu - (setq buffers-menu (cons 'keymap buffers-menu))) - (if frames-menu - (setq frames-menu (cons 'keymap frames-menu))) - (define-key global-map [menu-bar buffer] - (cons "Buffers" - (if (and buffers-menu frames-menu) - (list 'keymap "Buffers and Frames" - (cons 'buffers (cons "Buffers" buffers-menu)) - (cons 'frames (cons "Frames" frames-menu))) - (or buffers-menu frames-menu 'undefined))))))) + ;; If user discards the Buffers item, play along. + (and (lookup-key (current-global-map) [menu-bar buffer]) + (frame-or-buffer-changed-p) + (let ((buffers (buffer-list)) + (frames (frame-list)) + (maxlen 0) + buffers-menu frames-menu) + ;; If requested, list only the N most recently selected buffers. + (if (and (integerp buffers-menu-max-size) + (> buffers-menu-max-size 1)) + (if (> (length buffers) buffers-menu-max-size) + (setcdr (nthcdr buffers-menu-max-size buffers) nil))) + + ;; Make the menu of buffers proper. + (setq buffers-menu + (cons "Select Buffer" + (let* ((buffer-list + (mapcar 'list buffers)) + tail + (menu-bar-update-buffers-maxbuf 0) + alist + head) + ;; Put into each element of buffer-list + ;; the name for actual display, + ;; perhaps truncated in the middle. + (setq tail buffer-list) + (while tail + (let ((name (buffer-name (car (car tail))))) + (setcdr (car tail) + (if (> (length name) 27) + (concat (substring name 0 12) + "..." + (substring name -12)) + name))) + (setq tail (cdr tail))) + ;; Compute the maximum length of any name. + (setq tail buffer-list) + (while tail + (or (eq ?\ (aref (cdr (car tail)) 0)) + (setq menu-bar-update-buffers-maxbuf + (max menu-bar-update-buffers-maxbuf + (length (cdr (car tail)))))) + (setq tail (cdr tail))) + ;; Set ALIST to an alist of the form + ;; ITEM-STRING . BUFFER + (setq tail buffer-list) + (while tail + (let ((elt (car tail))) + (or (eq ?\ (aref (cdr elt) 0)) + (setq alist (cons + (menu-bar-update-buffers-1 elt) + alist))) + (and alist (> (length (car (car alist))) maxlen) + (setq maxlen (length (car (car alist)))))) + (setq tail (cdr tail))) + (setq alist (nreverse alist)) + ;; Make the menu item for list-buffers + ;; or reuse the one we already have. + ;; The advantage in reusing one + ;; is that it already has the keyboard equivalent + ;; cached, so we save the time to look that up again. + (or menu-bar-buffers-menu-list-buffers-entry + (setq menu-bar-buffers-menu-list-buffers-entry + (cons + 'list-buffers + (cons + "" + 'list-buffers)))) + ;; Update the item string for menu's new width. + (setcar (cdr menu-bar-buffers-menu-list-buffers-entry) + (concat (make-string (max (- (/ maxlen 2) 8) 0) + ?\ ) + "List All Buffers")) + ;; Now make the actual list of items, + ;; ending with the list-buffers item. + (nconc (mapcar '(lambda (pair) + ;; This is somewhat risque, to use + ;; the buffer name itself as the event + ;; type to define, but it works. + ;; It would not work to use the buffer + ;; since a buffer as an event has its + ;; own meaning. + (nconc (list (buffer-name (cdr pair)) + (car pair) + (cons nil nil)) + 'menu-bar-select-buffer)) + alist) + (list menu-bar-buffers-menu-list-buffers-entry))))) + + + ;; Make a Frames menu if we have more than one frame. + (if (cdr frames) + (let ((name (concat (make-string (max (- (/ maxlen 2) 3) 0) + ?\ ) + "Frames")) + (frames-menu + (cons 'keymap + (cons "Select Frame" + (mapcar '(lambda (frame) + (nconc (list frame + (cdr (assq 'name + (frame-parameters frame))) + (cons nil nil)) + 'menu-bar-select-frame)) + frames))))) + ;; Put it underneath the Buffers menu. + (setq buffers-menu (cons (cons 'frames (cons name frames-menu)) + buffers-menu)))) + (if buffers-menu + (setq buffers-menu (cons 'keymap buffers-menu))) + (define-key (current-global-map) [menu-bar buffer] + (cons "Buffers" buffers-menu))))) (add-hook 'menu-bar-update-hook 'menu-bar-update-buffers) +(menu-bar-update-buffers) + ;; this version is too slow ;;;(defun format-buffers-menu-line (buffer) ;;; "Returns a string to represent the given buffer in the Buffer menu. @@ -380,6 +639,48 @@ A large number or nil slows down menu responsiveness.") ;;; mode-name ;;; (or (buffer-file-name) "")))))) +;;; Set up a menu bar menu for the minibuffer. + +(mapcar + (function + (lambda (map) + (define-key map [menu-bar minibuf] + (cons "Minibuf" (make-sparse-keymap "Minibuf"))))) + (list minibuffer-local-ns-map + minibuffer-local-must-match-map + minibuffer-local-isearch-map + minibuffer-local-map + minibuffer-local-completion-map)) + +(mapcar + (function + (lambda (map) + (define-key map [menu-bar minibuf ?\?] + '("List Completions" . minibuffer-completion-help)) + (define-key map [menu-bar minibuf space] + '("Complete Word" . minibuffer-complete-word)) + (define-key map [menu-bar minibuf tab] + '("Complete" . minibuffer-complete)) + )) + (list minibuffer-local-must-match-map + minibuffer-local-completion-map)) + +(mapcar + (function + (lambda (map) + (define-key map [menu-bar minibuf quit] + '("Quit" . keyboard-escape-quit)) + (define-key map [menu-bar minibuf return] + '("Enter" . exit-minibuffer)) + )) + (list minibuffer-local-ns-map + minibuffer-local-must-match-map + minibuffer-local-isearch-map + minibuffer-local-map + minibuffer-local-completion-map)) + +(defvar menu-bar-mode nil) + (defun menu-bar-mode (flag) "Toggle display of a menu bar on each frame. This command applies to all frames that exist and frames to be @@ -388,30 +689,36 @@ With a numeric argument, if the argument is negative, turn off menu bars; otherwise, turn on menu bars." (interactive "P") - ;; Obtain the current setting by looking at default-frame-alist. - (let ((menu-bar-mode - (not (zerop (let ((assq (assq 'menu-bar-lines default-frame-alist))) - (if assq (cdr assq) 0)))))) - - ;; Tweedle it according to the argument. - (setq menu-bar-mode (if (null flag) (not menu-bar-mode) - (> (prefix-numeric-value flag) 0))) - - ;; Apply it to default-frame-alist. - (let ((parameter (assq 'menu-bar-lines default-frame-alist))) - (if (consp parameter) - (setcdr parameter (if menu-bar-mode 1 0)) - (setq default-frame-alist - (cons (cons 'menu-bar-lines (if menu-bar-mode 1 0)) - default-frame-alist)))) - - ;; Apply it to existing frames. - (let ((frames (frame-list))) - (while frames + ;; Make menu-bar-mode and default-frame-alist consistent. + (let ((default (assq 'menu-bar-lines default-frame-alist))) + (if default + (setq menu-bar-mode (not (eq (cdr default) 0))) + (setq default-frame-alist + (cons (cons 'menu-bar-lines (if menu-bar-mode 1 0)) + default-frame-alist)))) + + ;; Toggle or set the mode, according to FLAG. + (setq menu-bar-mode (if (null flag) (not menu-bar-mode) + (> (prefix-numeric-value flag) 0))) + + ;; Apply it to default-frame-alist. + (let ((parameter (assq 'menu-bar-lines default-frame-alist))) + (if (consp parameter) + (setcdr parameter (if menu-bar-mode 1 0)) + (setq default-frame-alist + (cons (cons 'menu-bar-lines (if menu-bar-mode 1 0)) + default-frame-alist)))) + + ;; Apply it to existing frames. + (let ((frames (frame-list))) + (while frames + (let ((height (cdr (assq 'height (frame-parameters (car frames)))))) (modify-frame-parameters (car frames) (list (cons 'menu-bar-lines - (if menu-bar-mode 1 0)))) - (setq frames (cdr frames)))))) + (if menu-bar-mode 1 0)))) + (modify-frame-parameters (car frames) + (list (cons 'height height)))) + (setq frames (cdr frames))))) (provide 'menu-bar)