X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/795e7a5b3202851a89a042578ee572962a723d65..e11a3bd1d1848d0a3a2ac21a48360eb628127ed9:/lisp/menu-bar.el diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el index 60f2bc2999..0da430140d 100644 --- a/lisp/menu-bar.el +++ b/lisp/menu-bar.el @@ -1307,26 +1307,6 @@ mail status in mode line")) ;; The "Tools" menu items -(defun send-mail-item-name () - (let* ((known-send-mail-commands '((sendmail-user-agent . "sendmail") - (mh-e-user-agent . "MH") - (message-user-agent . "Gnus Message") - (gnus-user-agent . "Gnus"))) - (name (assq mail-user-agent known-send-mail-commands))) - (if name - (setq name (cdr name)) - (setq name (symbol-name mail-user-agent)) - (if (string-match "\\(.+\\)-user-agent" name) - (setq name (match-string 1 name)))) - name)) - -(defun read-mail-item-name () - (let* ((known-rmail-commands '((rmail . "RMAIL") - (mh-rmail . "MH") - (gnus . "Gnus"))) - (known (assq read-mail-command known-rmail-commands))) - (if known (cdr known) (symbol-name read-mail-command)))) - (defvar menu-bar-games-menu (let ((menu (make-sparse-keymap "Games"))) @@ -1473,18 +1453,17 @@ mail status in mode line")) (bindings--define-key menu [directory-search] '(menu-item "Directory Search" eudc-tools-menu)) (bindings--define-key menu [compose-mail] - '(menu-item (format "Send Mail (with %s)" (send-mail-item-name)) compose-mail + '(menu-item "Compose New Mail" compose-mail :visible (and mail-user-agent (not (eq mail-user-agent 'ignore))) - :help "Send a mail message")) + :help "Start writing a new mail message")) (bindings--define-key menu [rmail] - '(menu-item (format "Read Mail (with %s)" (read-mail-item-name)) - menu-bar-read-mail + '(menu-item "Read Mail" menu-bar-read-mail :visible (and read-mail-command (not (eq read-mail-command 'ignore))) - :help "Read your mail and reply to it")) + :help "Read your mail")) (bindings--define-key menu [gnus] - '(menu-item "Read Net News (Gnus)" gnus + '(menu-item "Read Net News" gnus :help "Read network news groups")) (bindings--define-key menu [separator-vc] @@ -1518,7 +1497,7 @@ mail status in mode line")) :button (:toggle . (bound-and-true-p semantic-mode)))) (bindings--define-key menu [ede] - '(menu-item "Project support (EDE)" + '(menu-item "Project Support (EDE)" global-ede-mode :help "Toggle the Emacs Development Environment (Global EDE mode)" :button (:toggle . (bound-and-true-p global-ede-mode)))) @@ -2203,13 +2182,91 @@ See `menu-bar-mode' for more information." (declare-function x-menu-bar-open "term/x-win" (&optional frame)) (declare-function w32-menu-bar-open "term/w32-win" (&optional frame)) +(defun popup-menu (menu &optional position prefix) + "Popup the given menu and call the selected option. +MENU can be a keymap, an easymenu-style menu or a list of keymaps as for +`x-popup-menu'. +The menu is shown at the place where POSITION specifies. About +the form of POSITION, see `popup-menu-normalize-position'. +PREFIX is the prefix argument (if any) to pass to the command." + (let* ((map (cond + ((keymapp menu) menu) + ((and (listp menu) (keymapp (car menu))) menu) + (t (let* ((map (easy-menu-create-menu (car menu) (cdr menu))) + (filter (when (symbolp map) + (plist-get (get map 'menu-prop) :filter)))) + (if filter (funcall filter (symbol-function map)) map))))) + event cmd + (position (popup-menu-normalize-position position))) + ;; The looping behavior was taken from lmenu's popup-menu-popup + (while (and map (setq event + ;; map could be a prefix key, in which case + ;; we need to get its function cell + ;; definition. + (x-popup-menu position (indirect-function map)))) + ;; Strangely x-popup-menu returns a list. + ;; mouse-major-mode-menu was using a weird: + ;; (key-binding (apply 'vector (append '(menu-bar) menu-prefix events))) + (setq cmd + (if (and (not (keymapp map)) (listp map)) + ;; We were given a list of keymaps. Search them all + ;; in sequence until a first binding is found. + (let ((mouse-click (apply 'vector event)) + binding) + (while (and map (null binding)) + (setq binding (lookup-key (car map) mouse-click)) + (if (numberp binding) ; `too long' + (setq binding nil)) + (setq map (cdr map))) + binding) + ;; We were given a single keymap. + (lookup-key map (apply 'vector event)))) + ;; Clear out echoing, which perhaps shows a prefix arg. + (message "") + ;; Maybe try again but with the submap. + (setq map (if (keymapp cmd) cmd))) + ;; If the user did not cancel by refusing to select, + ;; and if the result is a command, run it. + (when (and (null map) (commandp cmd)) + (setq prefix-arg prefix) + ;; `setup-specified-language-environment', for instance, + ;; expects this to be set from a menu keymap. + (setq last-command-event (car (last event))) + ;; mouse-major-mode-menu was using `command-execute' instead. + (call-interactively cmd)))) + +(defun popup-menu-normalize-position (position) + "Convert the POSITION to the form which `popup-menu' expects internally. +POSITION can an event, a posn- value, a value having +form ((XOFFSET YOFFSET) WINDOW), or nil. +If nil, the current mouse position is used." + (pcase position + ;; nil -> mouse cursor position + (`nil + (let ((mp (mouse-pixel-position))) + (list (list (cadr mp) (cddr mp)) (car mp)))) + ;; Value returned from `event-end' or `posn-at-point'. + ((pred posnp) + (let ((xy (posn-x-y position))) + (list (list (car xy) (cdr xy)) + (posn-window position)))) + ;; Event. + ((pred eventp) + (popup-menu-normalize-position (event-end position))) + (t position))) + +;; FIXME: Make this a defcustom! +(defvar tty-menu-open-use-tmm nil + "If non-nil, menu-bar-open on a TTY will invoke `tmm-menubar'.") + (defun menu-bar-open (&optional frame) "Start key navigation of the menu bar in FRAME. This function decides which method to use to access the menu depending on FRAME's terminal device. On X displays, it calls -`x-menu-bar-open'; on Windows, `w32-menu-bar-open' otherwise it -calls `tmm-menubar'. +`x-menu-bar-open'; on Windows, `w32-menu-bar-open'; otherwise it +calls either `popup-menu' or `tmm-menubar' depending on whether +\`tty-menu-open-use-tmm' is nil or not. If FRAME is nil or not given, use the selected frame." (interactive) @@ -2217,6 +2274,8 @@ If FRAME is nil or not given, use the selected frame." (cond ((eq type 'x) (x-menu-bar-open frame)) ((eq type 'w32) (w32-menu-bar-open frame)) + ((null tty-menu-open-use-tmm) + (popup-menu menu-bar-file-menu (posn-at-x-y 0 0 nil t))) (t (with-selected-frame (or frame (selected-frame)) (tmm-menubar))))))