tmm.el 21.5 KB
Newer Older
1
;;; tmm.el --- text mode access to menu-bar  -*- lexical-binding: t -*-
Richard M. Stallman's avatar
Richard M. Stallman committed
2

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 1994-1996, 2000-2019 Free Software Foundation, Inc.
Richard M. Stallman's avatar
Richard M. Stallman committed
4 5

;; Author: Ilya Zakharevich <ilya@math.mps.ohio-state.edu>
6
;; Maintainer: emacs-devel@gnu.org
7
;; Keywords: convenience
Richard M. Stallman's avatar
Richard M. Stallman committed
8

Richard M. Stallman's avatar
Richard M. Stallman committed
9
;; This file is part of GNU Emacs.
Richard M. Stallman's avatar
Richard M. Stallman committed
10

11
;; GNU Emacs is free software: you can redistribute it and/or modify
Richard M. Stallman's avatar
Richard M. Stallman committed
12
;; it under the terms of the GNU General Public License as published by
13 14
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Richard M. Stallman's avatar
Richard M. Stallman committed
15 16 17 18 19 20 21

;; GNU Emacs 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
22
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
Richard M. Stallman's avatar
Richard M. Stallman committed
23

Erik Naggum's avatar
Erik Naggum committed
24
;;; Commentary:
Richard M. Stallman's avatar
Richard M. Stallman committed
25

26
;; This package provides text mode access to the menu bar.
Richard M. Stallman's avatar
Richard M. Stallman committed
27

Erik Naggum's avatar
Erik Naggum committed
28
;;; Code:
Richard M. Stallman's avatar
Richard M. Stallman committed
29 30 31

(require 'electric)

Stephen Eglen's avatar
Stephen Eglen committed
32 33 34 35 36
(defgroup tmm nil
  "Text mode access to menu-bar."
  :prefix "tmm-"
  :group 'menu)

Richard M. Stallman's avatar
Richard M. Stallman committed
37 38
;;; The following will be localized, added only to pacify the compiler.
(defvar tmm-short-cuts)
39
(defvar tmm-old-mb-map nil)
Nick Roberts's avatar
Nick Roberts committed
40
(defvar tmm-c-prompt nil)
Richard M. Stallman's avatar
Richard M. Stallman committed
41
(defvar tmm-km-list)
42
(defvar tmm-next-shortcut-digit)
Richard M. Stallman's avatar
Richard M. Stallman committed
43 44
(defvar tmm-table-undef)

45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61
(defun tmm-menubar-keymap ()
  "Return the current menu-bar keymap.

The ordering of the return value respects `menu-bar-final-items'."
  (let ((menu-bar '())
        (menu-end '()))
    (map-keymap
     (lambda (key binding)
       (push (cons key binding)
             ;; If KEY is the name of an item that we want to put last,
             ;; move it to the end.
             (if (memq key menu-bar-final-items)
                 menu-end
               menu-bar)))
     (tmm-get-keybind [menu-bar]))
    `(keymap ,@(nreverse menu-bar) ,@(nreverse menu-end))))

62
;;;###autoload (define-key global-map "\M-`" 'tmm-menubar)
63
;;;###autoload (define-key global-map [menu-bar mouse-1] 'tmm-menubar-mouse)
64

Richard M. Stallman's avatar
Richard M. Stallman committed
65
;;;###autoload
66
(defun tmm-menubar (&optional x-position)
Richard M. Stallman's avatar
Richard M. Stallman committed
67
  "Text-mode emulation of looking and choosing from a menubar.
68 69
See the documentation for `tmm-prompt'.
X-POSITION, if non-nil, specifies a horizontal position within the menu bar;
70 71 72 73
we make that menu bar item (the one at that position) the default choice.

Note that \\[menu-bar-open] by default drops down TTY menus; if you want it
to invoke `tmm-menubar' instead, customize the variable
74
`tty-menu-open-use-tmm' to a non-nil value."
Richard M. Stallman's avatar
Richard M. Stallman committed
75 76
  (interactive)
  (run-hooks 'menu-bar-update-hook)
77
  ;; Obey menu-bar-final-items; put those items last.
78
  (let ((menu-bar (tmm-menubar-keymap))
79 80
	menu-bar-item)
    (if x-position
81 82
	(let ((column 0)
              prev-key)
83 84 85 86
          (catch 'done
            (map-keymap
             (lambda (key binding)
               (when (> column x-position)
87
                 (setq menu-bar-item prev-key)
88
                 (throw 'done nil))
89
               (setq prev-key key)
90 91 92 93 94 95 96 97 98 99
               (pcase binding
                 ((or `(,(and (pred stringp) name) . ,_) ;Simple menu item.
                      `(menu-item ,name ,_cmd            ;Extended menu item.
                        . ,(and props
                                (guard (let ((visible
                                              (plist-get props :visible)))
                                         (or (null visible)
                                             (eval visible)))))))
                  (setq column (+ column (length name) 1)))))
             menu-bar))))
100 101
    (tmm-prompt menu-bar nil menu-bar-item)))

102
;;;###autoload
103 104 105 106 107 108 109
(defun tmm-menubar-mouse (event)
  "Text-mode emulation of looking and choosing from a menubar.
This command is used when you click the mouse in the menubar
on a console which has no window system but does have a mouse.
See the documentation for `tmm-prompt'."
  (interactive "e")
  (tmm-menubar (car (posn-x-y (event-start event)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
110

Stephen Eglen's avatar
Stephen Eglen committed
111
(defcustom tmm-mid-prompt "==>"
112
  "String to insert between shortcut and menu item.
113
If nil, there will be no shortcuts.  It should not consist only of spaces,
Stephen Eglen's avatar
Stephen Eglen committed
114 115 116
or else the correct item might not be found in the `*Completions*' buffer."
  :type 'string
  :group 'tmm)
Richard M. Stallman's avatar
Richard M. Stallman committed
117 118 119 120

(defvar tmm-mb-map nil
  "A place to store minibuffer map.")

121
(defcustom tmm-completion-prompt
122
  "Press PageUp key to reach this buffer from the minibuffer.
Richard M. Stallman's avatar
Richard M. Stallman committed
123
Alternatively, you can use Up/Down keys (or your History keys) to change
124
the item in the minibuffer, and press RET when you are done, or press the
125
marked letters to pick up your choice.  Type C-g or ESC ESC ESC to cancel.
Richard M. Stallman's avatar
Richard M. Stallman committed
126
"
127
  "Help text to insert on the top of the completion buffer.
128
To save space, you can set this to nil,
Stephen Eglen's avatar
Stephen Eglen committed
129 130 131
in which case the standard introduction text is deleted too."
  :type '(choice string (const nil))
  :group 'tmm)
132

Stephen Eglen's avatar
Stephen Eglen committed
133
(defcustom tmm-shortcut-style '(downcase upcase)
134
  "What letters to use as menu shortcuts.
135
Must be either one of the symbols `downcase' or `upcase',
Stephen Eglen's avatar
Stephen Eglen committed
136 137 138 139 140
or else a list of the two in the order you prefer."
  :type '(choice (const downcase)
		 (const upcase)
		 (repeat (choice (const downcase) (const upcase))))
  :group 'tmm)
141

Stephen Eglen's avatar
Stephen Eglen committed
142
(defcustom tmm-shortcut-words 2
143
  "How many successive words to try for shortcuts, nil means all.
144
If you use only one of `downcase' or `upcase' for `tmm-shortcut-style',
Stephen Eglen's avatar
Stephen Eglen committed
145 146 147
specify nil for this variable."
  :type '(choice integer (const nil))
  :group 'tmm)
Richard M. Stallman's avatar
Richard M. Stallman committed
148

149
(defface tmm-inactive
150
  '((t :inherit shadow))
Nick Roberts's avatar
Nick Roberts committed
151 152 153
  "Face used for inactive menu items."
  :group 'tmm)

154 155 156 157 158 159
(defun tmm--completion-table (items)
  (lambda (string pred action)
    (if (eq action 'metadata)
	'(metadata (display-sort-function . identity))
      (complete-with-action action items string pred))))

160 161
(defvar tmm--history nil)

Richard M. Stallman's avatar
Richard M. Stallman committed
162
;;;###autoload
163
(defun tmm-prompt (menu &optional in-popup default-item no-execute)
Richard M. Stallman's avatar
Richard M. Stallman committed
164
  "Text-mode emulation of calling the bindings in keymap.
165 166 167
Creates a text-mode menu of possible choices.  You can access the elements
in the menu in two ways:
   *)  via history mechanism from minibuffer;
Richard M. Stallman's avatar
Richard M. Stallman committed
168 169
   *)  Or via completion-buffer that is automatically shown.
The last alternative is currently a hack, you cannot use mouse reliably.
170 171 172 173

MENU is like the MENU argument to `x-popup-menu': either a
keymap or an alist of alists.
DEFAULT-ITEM, if non-nil, specifies an initial default choice.
174 175 176
Its value should be an event that has a binding in MENU.
NO-EXECUTE, if non-nil, means to return the command the user selects
instead of executing it."
177 178 179 180 181
  ;; If the optional argument IN-POPUP is t,
  ;; then MENU is an alist of elements of the form (STRING . VALUE).
  ;; That is used for recursive calls only.
  (let ((gl-str "Menu bar")  ;; The menu bar itself is not a menu keymap
					; so it doesn't have a name.
182
	tmm-km-list out history-len tmm-table-undef tmm-c-prompt
183
	tmm-old-mb-map tmm-short-cuts
184 185
	chosen-string choice
	(not-menu (not (keymapp menu))))
Richard M. Stallman's avatar
Richard M. Stallman committed
186
    (run-hooks 'activate-menubar-hook)
187 188 189 190
    ;; Compute tmm-km-list from MENU.
    ;; tmm-km-list is an alist of (STRING . MEANING).
    ;; It has no other elements.
    ;; The order of elements in tmm-km-list is the order of the menu bar.
191 192 193 194 195 196 197 198 199
    (if (not not-menu)
        (map-keymap (lambda (k v) (tmm-get-keymap (cons k v))) menu)
      (dolist (elt menu)
        (cond
         ((stringp elt) (setq gl-str elt))
         ((listp elt) (tmm-get-keymap elt not-menu))
         ((vectorp elt)
          (dotimes (i (length elt))
            (tmm-get-keymap (cons i (aref elt i)) not-menu))))))
200 201 202 203 204 205 206
    ;; Choose an element of tmm-km-list; put it in choice.
    (if (and not-menu (= 1 (length tmm-km-list)))
	;; If this is the top-level of an x-popup-menu menu,
	;; and there is just one pane, choose that one silently.
	;; This way we only ask the user one question,
	;; for which element of that pane.
	(setq choice (cdr (car tmm-km-list)))
207 208
      (unless tmm-km-list
	(error "Empty menu reached"))
209 210 211 212 213 214 215 216 217
      (and tmm-km-list
	   (let ((index-of-default 0))
	     (if tmm-mid-prompt
		 (setq tmm-km-list (tmm-add-shortcuts tmm-km-list))
	       t)
	     ;; Find the default item's index within the menu bar.
	     ;; We use this to decide the initial minibuffer contents
	     ;; and initial history position.
	     (if default-item
218
		 (let ((tail menu) visible)
219 220 221 222 223
		   (while (and tail
			       (not (eq (car-safe (car tail)) default-item)))
		     ;; Be careful to count only the elements of MENU
		     ;; that actually constitute menu bar items.
		     (if (and (consp (car tail))
224
			      (or (stringp (car-safe (cdr (car tail))))
225 226 227 228 229 230 231
				  (and
				   (eq (car-safe (cdr (car tail))) 'menu-item)
				   (progn
				     (setq visible
					   (plist-get
					    (nthcdr 4 (car tail)) :visible))
				     (or (not visible) (eval visible))))))
232 233
			 (setq index-of-default (1+ index-of-default)))
		     (setq tail (cdr tail)))))
Nick Roberts's avatar
Nick Roberts committed
234
             (let ((prompt (concat "^." (regexp-quote tmm-mid-prompt))))
235
               (setq tmm--history
Nick Roberts's avatar
Nick Roberts committed
236 237 238 239 240 241
                     (reverse (delq nil
                                    (mapcar
                                     (lambda (elt)
                                       (if (string-match prompt (car elt))
                                           (car elt)))
                                     tmm-km-list)))))
242 243 244 245 246
	     (setq history-len (length tmm--history))
	     (setq tmm--history (append tmm--history tmm--history
                                        tmm--history tmm--history))
	     (setq tmm-c-prompt (nth (- history-len 1 index-of-default)
                                     tmm--history))
247 248 249 250
             (setq out
                   (if default-item
                       (car (nth index-of-default tmm-km-list))
                     (minibuffer-with-setup-hook #'tmm-add-prompt
251 252 253 254 255 256 257
                       ;; tmm-km-list is reversed, because history
                       ;; needs it in LIFO order.  But completion
                       ;; needs it in non-reverse order, so that the
                       ;; menu items are displayed as completion
                       ;; candidates in the order they are shown on
                       ;; the menu bar.  So pass completing-read the
                       ;; reversed copy of the list.
258
                       (completing-read-default
259 260
                        (concat gl-str
                                " (up/down to change, PgUp to menu): ")
261
                        (tmm--completion-table (reverse tmm-km-list)) nil t nil
262
                        (cons 'tmm--history
263
                              (- (* 2 history-len) index-of-default))))))))
264 265
      (setq choice (cdr (assoc out tmm-km-list)))
      (and (null choice)
266
           (string-prefix-p tmm-c-prompt out)
267 268
	   (setq out (substring out (length tmm-c-prompt))
		 choice (cdr (assoc out tmm-km-list))))
269
      (and (null choice) out
270 271 272 273 274 275 276 277 278
	   (setq out (try-completion out tmm-km-list)
		 choice (cdr (assoc  out tmm-km-list)))))
    ;; CHOICE is now (STRING . MEANING).  Separate the two parts.
    (setq chosen-string (car choice))
    (setq choice (cdr choice))
    (cond (in-popup
	   ;; We just did the inner level of a -popup menu.
	   choice)
	  ;; We just did the outer level.  Do the inner level now.
279
	  (not-menu (tmm-prompt choice t nil no-execute))
280 281 282 283 284 285 286
	  ;; We just handled a menu keymap and found another keymap.
	  ((keymapp choice)
	   (if (symbolp choice)
	       (setq choice (indirect-function choice)))
	   (condition-case nil
	       (require 'mouse)
	     (error nil))
287
	   (tmm-prompt choice nil nil no-execute))
288 289 290
	  ;; We just handled a menu keymap and found a command.
	  (choice
	   (if chosen-string
291
	       (if no-execute choice
292 293
		 (setq last-command-event chosen-string)
		 (call-interactively choice))
294
	     choice)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
295 296

(defun tmm-add-shortcuts (list)
297
  "Add shortcuts to cars of elements of the list.
Richard M. Stallman's avatar
Richard M. Stallman committed
298
Takes a list of lists with a string as car, returns list with
299 300
shortcuts added to these cars.
Stores a list of all the shortcuts in the free variable `tmm-short-cuts'."
301 302
  (let ((tmm-next-shortcut-digit ?0))
    (mapcar 'tmm-add-one-shortcut (reverse list))))
Richard M. Stallman's avatar
Richard M. Stallman committed
303

304 305
(defsubst tmm-add-one-shortcut (elt)
;; uses the free vars tmm-next-shortcut-digit and tmm-short-cuts
Nick Roberts's avatar
Nick Roberts committed
306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339
  (cond
   ((eq (cddr elt) 'ignore)
    (cons (concat " " (make-string (length tmm-mid-prompt) ?\-)
                  (car elt))
          (cdr elt)))
   (t
    (let* ((str (car elt))
           (paren (string-match "(" str))
           (pos 0) (word 0) char)
      (catch 'done                             ; ??? is this slow?
        (while (and (or (not tmm-shortcut-words)   ; no limit on words
                        (< word tmm-shortcut-words)) ; try n words
                    (setq pos (string-match "\\w+" str pos)) ; get next word
                    (not (and paren (> pos paren)))) ; don't go past "(binding.."
          (if (or (= pos 0)
                  (/= (aref str (1- pos)) ?.)) ; avoid file extensions
              (let ((shortcut-style
                     (if (listp tmm-shortcut-style) ; convert to list
                         tmm-shortcut-style
                       (list tmm-shortcut-style))))
                (while shortcut-style ; try upcase and downcase variants
                  (setq char (funcall (car shortcut-style) (aref str pos)))
                  (if (not (memq char tmm-short-cuts)) (throw 'done char))
                  (setq shortcut-style (cdr shortcut-style)))))
          (setq word (1+ word))
          (setq pos (match-end 0)))
        (while (<= tmm-next-shortcut-digit ?9) ; no letter shortcut, pick a digit
          (setq char tmm-next-shortcut-digit)
          (setq tmm-next-shortcut-digit (1+ tmm-next-shortcut-digit))
          (if (not (memq char tmm-short-cuts)) (throw 'done char)))
        (setq char nil))
      (if char (setq tmm-short-cuts (cons char tmm-short-cuts)))
      (cons (concat (if char (concat (char-to-string char) tmm-mid-prompt)
                      ;; keep them lined up in columns
340
                      (make-string (1+ (length tmm-mid-prompt)) ?\s))
Nick Roberts's avatar
Nick Roberts committed
341 342
                    str)
            (cdr elt))))))
343 344

;; This returns the old map.
345
(defun tmm-define-keys (minibuffer)
346 347
  (let ((map (make-sparse-keymap)))
    (suppress-keymap map t)
348 349 350 351 352 353 354
    (dolist (c tmm-short-cuts)
      (if (listp tmm-shortcut-style)
          (define-key map (char-to-string c) 'tmm-shortcut)
        ;; only one kind of letters are shortcuts, so map both upcase and
        ;; downcase input to the same
        (define-key map (char-to-string (downcase c)) 'tmm-shortcut)
        (define-key map (char-to-string (upcase c)) 'tmm-shortcut)))
355 356 357 358 359 360 361 362 363 364 365
    (if minibuffer
	(progn
          (define-key map [pageup] 'tmm-goto-completions)
          (define-key map [prior] 'tmm-goto-completions)
          (define-key map "\ev" 'tmm-goto-completions)
          (define-key map "\C-n" 'next-history-element)
          (define-key map "\C-p" 'previous-history-element)))
    (prog1 (current-local-map)
      (use-local-map (append map (current-local-map))))))

(defun tmm-completion-delete-prompt ()
366
  (with-current-buffer standard-output
367
  (goto-char (point-min))
368
    (delete-region (point) (search-forward "Possible completions are:\n"))))
369

Nick Roberts's avatar
Nick Roberts committed
370 371 372 373 374 375 376 377 378 379 380 381
(defun tmm-remove-inactive-mouse-face ()
  "Remove the mouse-face property from inactive menu items."
  (let ((inhibit-read-only t)
        (inactive-string
         (concat " " (make-string (length tmm-mid-prompt) ?\-)))
        next)
    (save-excursion
      (goto-char (point-min))
      (while (not (eobp))
        (setq next (next-single-char-property-change (point) 'mouse-face))
        (when (looking-at inactive-string)
          (remove-text-properties (point) next '(mouse-face))
382
          (add-text-properties (point) next '(face tmm-inactive)))
Nick Roberts's avatar
Nick Roberts committed
383 384 385
        (goto-char next)))
    (set-buffer-modified-p nil)))

Richard M. Stallman's avatar
Richard M. Stallman committed
386
(defun tmm-add-prompt ()
Nick Roberts's avatar
Nick Roberts committed
387 388
  (unless tmm-c-prompt
    (error "No active menu entries"))
Glenn Morris's avatar
Glenn Morris committed
389
  (setq tmm-old-mb-map (tmm-define-keys t))
390 391 392 393 394 395 396
  (or tmm-completion-prompt
      (add-hook 'completion-setup-hook
                'tmm-completion-delete-prompt 'append))
  (unwind-protect
      (minibuffer-completion-help)
    (remove-hook 'completion-setup-hook 'tmm-completion-delete-prompt))
  (with-current-buffer "*Completions*"
Glenn Morris's avatar
Glenn Morris committed
397 398
    (tmm-remove-inactive-mouse-face)
    (when tmm-completion-prompt
399 400
      (let ((inhibit-read-only t)
	    (window (get-buffer-window "*Completions*")))
401
	(goto-char (point-min))
402 403 404 405 406 407
	(insert tmm-completion-prompt)
	(when window
	  ;; Try to show everything just inserted and preserve height of
	  ;; *Completions* window.  This should fix a behavior described
	  ;; in Bug#1291.
	  (fit-window-to-buffer window nil nil nil nil t)))))
Glenn Morris's avatar
Glenn Morris committed
408
  (insert tmm-c-prompt))
Richard M. Stallman's avatar
Richard M. Stallman committed
409 410

(defun tmm-shortcut ()
411
  "Choose the shortcut that the user typed."
Richard M. Stallman's avatar
Richard M. Stallman committed
412
  (interactive)
413
  (let ((c last-command-event) s)
414 415 416
    (if (symbolp tmm-shortcut-style)
        (setq c (funcall tmm-shortcut-style c)))
    (if (memq c tmm-short-cuts)
417 418
	(if (equal (buffer-name) "*Completions*")
	    (progn
419
	      (goto-char (point-min))
420
	      (re-search-forward
421
	       (concat "\\(^\\|[ \t]\\)" (char-to-string c) tmm-mid-prompt))
422
	      (choose-completion))
423 424
	  ;; In minibuffer
	  (delete-region (minibuffer-prompt-end) (point-max))
425 426 427 428 429 430 431
	  (dolist (elt tmm-km-list)
            (if (string=
                 (substring (car elt) 0
                            (min (1+ (length tmm-mid-prompt))
                                 (length (car elt))))
                 (concat (char-to-string c) tmm-mid-prompt))
                (setq s (car elt))))
432 433
	  (insert s)
	  (exit-minibuffer)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
434 435

(defun tmm-goto-completions ()
436
  "Jump to the completions buffer."
Richard M. Stallman's avatar
Richard M. Stallman committed
437
  (interactive)
438 439
  (let ((prompt-end (minibuffer-prompt-end)))
    (setq tmm-c-prompt (buffer-substring prompt-end (point-max)))
440
    ;; FIXME: Why?
441
    (delete-region prompt-end (point-max)))
442
  (switch-to-buffer-other-window "*Completions*")
Richard M. Stallman's avatar
Richard M. Stallman committed
443 444 445
  (search-forward tmm-c-prompt)
  (search-backward tmm-c-prompt))

446
(defun tmm-get-keymap (elt &optional in-x-menu)
447
  "Prepend (DOCSTRING EVENT BINDING) to free variable `tmm-km-list'.
Richard M. Stallman's avatar
Richard M. Stallman committed
448
The values are deduced from the argument ELT, that should be an
449
element of keymap, an `x-popup-menu' argument, or an element of
Richard M. Stallman's avatar
Richard M. Stallman committed
450
`x-popup-menu' argument (when IN-X-MENU is not-nil).
451 452
This function adds the element only if it is not already present.
It uses the free variable `tmm-table-undef' to keep undefined keys."
453
  (let (km str plist filter visible enable (event (car elt)))
Richard M. Stallman's avatar
Richard M. Stallman committed
454 455 456
    (setq elt (cdr elt))
    (if (eq elt 'undefined)
	(setq tmm-table-undef (cons (cons event nil) tmm-table-undef))
457 458 459
      (unless (assoc event tmm-table-undef)
	(cond ((if (listp elt)
		   (or (keymapp elt) (eq (car elt) 'lambda))
460
		 (and (symbolp elt) (fboundp elt)))
461
	       (setq km elt))
462

463 464 465
	      ((if (listp (cdr-safe elt))
		   (or (keymapp (cdr-safe elt))
		       (eq (car (cdr-safe elt)) 'lambda))
466
		 (and (symbolp (cdr-safe elt)) (fboundp (cdr-safe elt))))
467 468
	       (setq km (cdr elt))
	       (and (stringp (car elt)) (setq str (car elt))))
469

470 471 472
	      ((if (listp (cdr-safe (cdr-safe elt)))
		   (or (keymapp (cdr-safe (cdr-safe elt)))
		       (eq (car (cdr-safe (cdr-safe elt))) 'lambda))
473
		 (and (symbolp (cdr-safe (cdr-safe elt)))
474
                      (fboundp (cdr-safe (cdr-safe elt)))))
475
	       (setq km (cddr elt))
476
	       (and (stringp (car elt)) (setq str (car elt))))
477

478
	      ((eq (car-safe elt) 'menu-item)
479
	       ;; (menu-item TITLE COMMAND KEY ...)
480
	       (setq plist (cdr-safe (cdr-safe (cdr-safe elt))))
481 482
	       (when (consp (car-safe plist))
		 (setq plist (cdr-safe plist)))
483
	       (setq km (nth 2 elt))
484
	       (setq str (eval (nth 1 elt)))
485 486 487
	       (setq filter (plist-get plist :filter))
	       (if filter
		   (setq km (funcall filter km)))
488 489 490
	       (setq visible (plist-get plist :visible))
	       (if visible
		   (setq km (and (eval visible) km)))
491 492
	       (setq enable (plist-get plist :enable))
	       (if enable
493
                   (setq km (if (eval enable) km 'ignore))))
494

495 496 497
	      ((if (listp (cdr-safe (cdr-safe (cdr-safe elt))))
		   (or (keymapp (cdr-safe (cdr-safe (cdr-safe elt))))
		       (eq (car (cdr-safe (cdr-safe (cdr-safe elt)))) 'lambda))
498 499
		 (and (symbolp (cdr-safe (cdr-safe (cdr-safe elt))))
		      (fboundp (cdr-safe (cdr-safe (cdr-safe elt))))))
500
                                        ; New style of easy-menu
501
	       (setq km (cdr (cddr elt)))
502
	       (and (stringp (car elt)) (setq str (car elt))))
503

504
	      ((stringp event)		; x-popup or x-popup element
505 506 507 508
               (setq str event)
               (setq event nil)
	       (setq km (if (or in-x-menu (stringp (car-safe elt)))
                            elt (cons 'keymap elt)))))
Glenn Morris's avatar
Glenn Morris committed
509
        (unless (or (eq km 'ignore) (null str))
510 511 512 513 514 515 516 517 518 519 520 521
          (let ((binding (where-is-internal km nil t)))
            (when binding
              (setq binding (key-description binding))
              ;; Try to align the keybindings.
              (let ((colwidth (min 30 (- (/ (window-width) 2) 10))))
                (setq str
                      (concat str
                              (make-string (max 2 (- colwidth
                                                     (string-width str)
                                                     (string-width binding)))
                                           ?\s)
                              binding)))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
522
      (and km (stringp km) (setq str km))
523 524 525
      ;; Verify that the command is enabled;
      ;; if not, don't mention it.
      (when (and km (symbolp km) (get km 'menu-enable))
Nick Roberts's avatar
Nick Roberts committed
526
	  (setq km (if (eval (get km 'menu-enable)) km 'ignore)))
Richard M. Stallman's avatar
Richard M. Stallman committed
527 528
      (and km str
	   (or (assoc str tmm-km-list)
529
	       (push (cons str (cons event km)) tmm-km-list))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
530 531

(defun tmm-get-keybind (keyseq)
532
  "Return the current binding of KEYSEQ, merging prefix definitions.
Karl Heuer's avatar
Karl Heuer committed
533
If KEYSEQ is a prefix key that has local and global bindings,
534 535 536
we merge them into a single keymap which shows the proper order of the menu.
However, for the menu bar itself, the value does not take account
of `menu-bar-final-items'."
537
  (lookup-key (cons 'keymap (nreverse (current-active-maps))) keyseq))
Richard M. Stallman's avatar
Richard M. Stallman committed
538 539 540 541

(provide 'tmm)

;;; tmm.el ends here