| 1 | ;;; tmm.el --- text mode access to menu-bar |
| 2 | |
| 3 | ;; Copyright (C) 1994, 1995, 1996, 2000, 2001, 2002, 2003, |
| 4 | ;; 2004, 2005, 2006 Free Software Foundation, Inc. |
| 5 | |
| 6 | ;; Author: Ilya Zakharevich <ilya@math.mps.ohio-state.edu> |
| 7 | ;; Maintainer: FSF |
| 8 | ;; Keywords: convenience |
| 9 | |
| 10 | ;; This file is part of GNU Emacs. |
| 11 | |
| 12 | ;; GNU Emacs is free software; you can redistribute it and/or modify |
| 13 | ;; it under the terms of the GNU General Public License as published by |
| 14 | ;; the Free Software Foundation; either version 2, or (at your option) |
| 15 | ;; any later version. |
| 16 | |
| 17 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 20 | ;; GNU General Public License for more details. |
| 21 | |
| 22 | ;; You should have received a copy of the GNU General Public License |
| 23 | ;; along with GNU Emacs; see the file COPYING. If not, write to the |
| 24 | ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
| 25 | ;; Boston, MA 02110-1301, USA. |
| 26 | |
| 27 | ;;; Commentary: |
| 28 | |
| 29 | ;; This package provides text mode access to the menu bar. |
| 30 | |
| 31 | ;;; Code: |
| 32 | |
| 33 | (require 'electric) |
| 34 | |
| 35 | (defgroup tmm nil |
| 36 | "Text mode access to menu-bar." |
| 37 | :prefix "tmm-" |
| 38 | :group 'menu) |
| 39 | |
| 40 | ;;; The following will be localized, added only to pacify the compiler. |
| 41 | (defvar tmm-short-cuts) |
| 42 | (defvar tmm-old-mb-map nil) |
| 43 | (defvar tmm-old-comp-map) |
| 44 | (defvar tmm-c-prompt) |
| 45 | (defvar tmm-km-list) |
| 46 | (defvar tmm-next-shortcut-digit) |
| 47 | (defvar tmm-table-undef) |
| 48 | |
| 49 | ;;;###autoload (define-key global-map "\M-`" 'tmm-menubar) |
| 50 | ;;;###autoload (define-key global-map [f10] 'tmm-menubar) |
| 51 | ;;;###autoload (define-key global-map [menu-bar mouse-1] 'tmm-menubar-mouse) |
| 52 | |
| 53 | ;;;###autoload |
| 54 | (defun tmm-menubar (&optional x-position) |
| 55 | "Text-mode emulation of looking and choosing from a menubar. |
| 56 | See the documentation for `tmm-prompt'. |
| 57 | X-POSITION, if non-nil, specifies a horizontal position within the menu bar; |
| 58 | we make that menu bar item (the one at that position) the default choice." |
| 59 | (interactive) |
| 60 | (run-hooks 'menu-bar-update-hook) |
| 61 | ;; Obey menu-bar-final-items; put those items last. |
| 62 | (let ((menu-bar (tmm-get-keybind [menu-bar])) |
| 63 | menu-bar-item) |
| 64 | (let ((list menu-bar-final-items)) |
| 65 | (while list |
| 66 | (let ((item (car list))) |
| 67 | ;; ITEM is the name of an item that we want to put last. |
| 68 | ;; Find it in MENU-BAR and move it to the end. |
| 69 | (let ((this-one (assq item menu-bar))) |
| 70 | (setq menu-bar (append (delq this-one menu-bar) |
| 71 | (list this-one))))) |
| 72 | (setq list (cdr list)))) |
| 73 | (if x-position |
| 74 | (let ((tail menu-bar) |
| 75 | this-one |
| 76 | (column 0)) |
| 77 | (while (and tail (< column x-position)) |
| 78 | (setq this-one (car tail)) |
| 79 | (if (and (consp (car tail)) |
| 80 | (consp (cdr (car tail))) |
| 81 | (stringp (nth 1 (car tail)))) |
| 82 | (setq column (+ column |
| 83 | (length (nth 1 (car tail))) |
| 84 | 1))) |
| 85 | (setq tail (cdr tail))) |
| 86 | (setq menu-bar-item (car this-one)))) |
| 87 | (tmm-prompt menu-bar nil menu-bar-item))) |
| 88 | |
| 89 | ;;;###autoload |
| 90 | (defun tmm-menubar-mouse (event) |
| 91 | "Text-mode emulation of looking and choosing from a menubar. |
| 92 | This command is used when you click the mouse in the menubar |
| 93 | on a console which has no window system but does have a mouse. |
| 94 | See the documentation for `tmm-prompt'." |
| 95 | (interactive "e") |
| 96 | (tmm-menubar (car (posn-x-y (event-start event))))) |
| 97 | |
| 98 | (defcustom tmm-mid-prompt "==>" |
| 99 | "*String to insert between shortcut and menu item. |
| 100 | If nil, there will be no shortcuts. It should not consist only of spaces, |
| 101 | or else the correct item might not be found in the `*Completions*' buffer." |
| 102 | :type 'string |
| 103 | :group 'tmm) |
| 104 | |
| 105 | (defvar tmm-mb-map nil |
| 106 | "A place to store minibuffer map.") |
| 107 | |
| 108 | (defcustom tmm-completion-prompt |
| 109 | "Press PageUp key to reach this buffer from the minibuffer. |
| 110 | Alternatively, you can use Up/Down keys (or your History keys) to change |
| 111 | the item in the minibuffer, and press RET when you are done, or press the |
| 112 | marked letters to pick up your choice. Type C-g or ESC ESC ESC to cancel. |
| 113 | " |
| 114 | "*Help text to insert on the top of the completion buffer. |
| 115 | To save space, you can set this to nil, |
| 116 | in which case the standard introduction text is deleted too." |
| 117 | :type '(choice string (const nil)) |
| 118 | :group 'tmm) |
| 119 | |
| 120 | (defcustom tmm-shortcut-style '(downcase upcase) |
| 121 | "*What letters to use as menu shortcuts. |
| 122 | Must be either one of the symbols `downcase' or `upcase', |
| 123 | or else a list of the two in the order you prefer." |
| 124 | :type '(choice (const downcase) |
| 125 | (const upcase) |
| 126 | (repeat (choice (const downcase) (const upcase)))) |
| 127 | :group 'tmm) |
| 128 | |
| 129 | (defcustom tmm-shortcut-words 2 |
| 130 | "*How many successive words to try for shortcuts, nil means all. |
| 131 | If you use only one of `downcase' or `upcase' for `tmm-shortcut-style', |
| 132 | specify nil for this variable." |
| 133 | :type '(choice integer (const nil)) |
| 134 | :group 'tmm) |
| 135 | |
| 136 | (defface tmm-inactive |
| 137 | '((t :inherit shadow)) |
| 138 | "Face used for inactive menu items." |
| 139 | :group 'tmm) |
| 140 | |
| 141 | ;;;###autoload |
| 142 | (defun tmm-prompt (menu &optional in-popup default-item) |
| 143 | "Text-mode emulation of calling the bindings in keymap. |
| 144 | Creates a text-mode menu of possible choices. You can access the elements |
| 145 | in the menu in two ways: |
| 146 | *) via history mechanism from minibuffer; |
| 147 | *) Or via completion-buffer that is automatically shown. |
| 148 | The last alternative is currently a hack, you cannot use mouse reliably. |
| 149 | |
| 150 | MENU is like the MENU argument to `x-popup-menu': either a |
| 151 | keymap or an alist of alists. |
| 152 | DEFAULT-ITEM, if non-nil, specifies an initial default choice. |
| 153 | Its value should be an event that has a binding in MENU." |
| 154 | ;; If the optional argument IN-POPUP is t, |
| 155 | ;; then MENU is an alist of elements of the form (STRING . VALUE). |
| 156 | ;; That is used for recursive calls only. |
| 157 | (let ((gl-str "Menu bar") ;; The menu bar itself is not a menu keymap |
| 158 | ; so it doesn't have a name. |
| 159 | tmm-km-list out history history-len tmm-table-undef tmm-c-prompt |
| 160 | tmm-old-mb-map tmm-old-comp-map tmm-short-cuts |
| 161 | chosen-string choice |
| 162 | (not-menu (not (keymapp menu)))) |
| 163 | (run-hooks 'activate-menubar-hook) |
| 164 | ;; Compute tmm-km-list from MENU. |
| 165 | ;; tmm-km-list is an alist of (STRING . MEANING). |
| 166 | ;; It has no other elements. |
| 167 | ;; The order of elements in tmm-km-list is the order of the menu bar. |
| 168 | (mapc (lambda (elt) |
| 169 | (if (stringp elt) |
| 170 | (setq gl-str elt) |
| 171 | (and (listp elt) (tmm-get-keymap elt not-menu)))) |
| 172 | menu) |
| 173 | ;; Choose an element of tmm-km-list; put it in choice. |
| 174 | (if (and not-menu (= 1 (length tmm-km-list))) |
| 175 | ;; If this is the top-level of an x-popup-menu menu, |
| 176 | ;; and there is just one pane, choose that one silently. |
| 177 | ;; This way we only ask the user one question, |
| 178 | ;; for which element of that pane. |
| 179 | (setq choice (cdr (car tmm-km-list))) |
| 180 | (unless tmm-km-list |
| 181 | (error "Empty menu reached")) |
| 182 | (and tmm-km-list |
| 183 | (let ((index-of-default 0)) |
| 184 | (if tmm-mid-prompt |
| 185 | (setq tmm-km-list (tmm-add-shortcuts tmm-km-list)) |
| 186 | t) |
| 187 | ;; Find the default item's index within the menu bar. |
| 188 | ;; We use this to decide the initial minibuffer contents |
| 189 | ;; and initial history position. |
| 190 | (if default-item |
| 191 | (let ((tail menu)) |
| 192 | (while (and tail |
| 193 | (not (eq (car-safe (car tail)) default-item))) |
| 194 | ;; Be careful to count only the elements of MENU |
| 195 | ;; that actually constitute menu bar items. |
| 196 | (if (and (consp (car tail)) |
| 197 | (or (stringp (car-safe (cdr (car tail)))) |
| 198 | (eq (car-safe (cdr (car tail))) 'menu-item))) |
| 199 | (setq index-of-default (1+ index-of-default))) |
| 200 | (setq tail (cdr tail))))) |
| 201 | (let ((prompt (concat "^." (regexp-quote tmm-mid-prompt)))) |
| 202 | (setq history |
| 203 | (reverse (delq nil |
| 204 | (mapcar |
| 205 | (lambda (elt) |
| 206 | (if (string-match prompt (car elt)) |
| 207 | (car elt))) |
| 208 | tmm-km-list))))) |
| 209 | (setq history-len (length history)) |
| 210 | (setq history (append history history history history)) |
| 211 | (setq tmm-c-prompt (nth (- history-len 1 index-of-default) history)) |
| 212 | (add-hook 'minibuffer-setup-hook 'tmm-add-prompt) |
| 213 | (save-excursion |
| 214 | (unwind-protect |
| 215 | (setq out |
| 216 | (completing-read |
| 217 | (concat gl-str " (up/down to change, PgUp to menu): ") |
| 218 | tmm-km-list nil t nil |
| 219 | (cons 'history (- (* 2 history-len) index-of-default)))) |
| 220 | (save-excursion |
| 221 | (remove-hook 'minibuffer-setup-hook 'tmm-add-prompt) |
| 222 | (if (get-buffer "*Completions*") |
| 223 | (progn |
| 224 | (set-buffer "*Completions*") |
| 225 | (use-local-map tmm-old-comp-map) |
| 226 | (bury-buffer (current-buffer))))) |
| 227 | )))) |
| 228 | (setq choice (cdr (assoc out tmm-km-list))) |
| 229 | (and (null choice) |
| 230 | (> (length out) (length tmm-c-prompt)) |
| 231 | (string= (substring out 0 (length tmm-c-prompt)) tmm-c-prompt) |
| 232 | (setq out (substring out (length tmm-c-prompt)) |
| 233 | choice (cdr (assoc out tmm-km-list)))) |
| 234 | (and (null choice) out |
| 235 | (setq out (try-completion out tmm-km-list) |
| 236 | choice (cdr (assoc out tmm-km-list))))) |
| 237 | ;; CHOICE is now (STRING . MEANING). Separate the two parts. |
| 238 | (setq chosen-string (car choice)) |
| 239 | (setq choice (cdr choice)) |
| 240 | (cond (in-popup |
| 241 | ;; We just did the inner level of a -popup menu. |
| 242 | choice) |
| 243 | ;; We just did the outer level. Do the inner level now. |
| 244 | (not-menu (tmm-prompt choice t)) |
| 245 | ;; We just handled a menu keymap and found another keymap. |
| 246 | ((keymapp choice) |
| 247 | (if (symbolp choice) |
| 248 | (setq choice (indirect-function choice))) |
| 249 | (condition-case nil |
| 250 | (require 'mouse) |
| 251 | (error nil)) |
| 252 | (condition-case nil |
| 253 | (x-popup-menu nil choice) ; Get the shortcuts |
| 254 | (error nil)) |
| 255 | (tmm-prompt choice)) |
| 256 | ;; We just handled a menu keymap and found a command. |
| 257 | (choice |
| 258 | (if chosen-string |
| 259 | (progn |
| 260 | (setq last-command-event chosen-string) |
| 261 | (call-interactively choice)) |
| 262 | choice))))) |
| 263 | |
| 264 | (defun tmm-add-shortcuts (list) |
| 265 | "Adds shortcuts to cars of elements of the list. |
| 266 | Takes a list of lists with a string as car, returns list with |
| 267 | shortcuts added to these cars. |
| 268 | Stores a list of all the shortcuts in the free variable `tmm-short-cuts'." |
| 269 | (let ((tmm-next-shortcut-digit ?0)) |
| 270 | (mapcar 'tmm-add-one-shortcut (reverse list)))) |
| 271 | |
| 272 | (defsubst tmm-add-one-shortcut (elt) |
| 273 | ;; uses the free vars tmm-next-shortcut-digit and tmm-short-cuts |
| 274 | (cond |
| 275 | ((eq (cddr elt) 'ignore) |
| 276 | (cons (concat " " (make-string (length tmm-mid-prompt) ?\-) |
| 277 | (car elt)) |
| 278 | (cdr elt))) |
| 279 | (t |
| 280 | (let* ((str (car elt)) |
| 281 | (paren (string-match "(" str)) |
| 282 | (pos 0) (word 0) char) |
| 283 | (catch 'done ; ??? is this slow? |
| 284 | (while (and (or (not tmm-shortcut-words) ; no limit on words |
| 285 | (< word tmm-shortcut-words)) ; try n words |
| 286 | (setq pos (string-match "\\w+" str pos)) ; get next word |
| 287 | (not (and paren (> pos paren)))) ; don't go past "(binding.." |
| 288 | (if (or (= pos 0) |
| 289 | (/= (aref str (1- pos)) ?.)) ; avoid file extensions |
| 290 | (let ((shortcut-style |
| 291 | (if (listp tmm-shortcut-style) ; convert to list |
| 292 | tmm-shortcut-style |
| 293 | (list tmm-shortcut-style)))) |
| 294 | (while shortcut-style ; try upcase and downcase variants |
| 295 | (setq char (funcall (car shortcut-style) (aref str pos))) |
| 296 | (if (not (memq char tmm-short-cuts)) (throw 'done char)) |
| 297 | (setq shortcut-style (cdr shortcut-style))))) |
| 298 | (setq word (1+ word)) |
| 299 | (setq pos (match-end 0))) |
| 300 | (while (<= tmm-next-shortcut-digit ?9) ; no letter shortcut, pick a digit |
| 301 | (setq char tmm-next-shortcut-digit) |
| 302 | (setq tmm-next-shortcut-digit (1+ tmm-next-shortcut-digit)) |
| 303 | (if (not (memq char tmm-short-cuts)) (throw 'done char))) |
| 304 | (setq char nil)) |
| 305 | (if char (setq tmm-short-cuts (cons char tmm-short-cuts))) |
| 306 | (cons (concat (if char (concat (char-to-string char) tmm-mid-prompt) |
| 307 | ;; keep them lined up in columns |
| 308 | (make-string (1+ (length tmm-mid-prompt)) ?\ )) |
| 309 | str) |
| 310 | (cdr elt)))))) |
| 311 | |
| 312 | ;; This returns the old map. |
| 313 | (defun tmm-define-keys (minibuffer) |
| 314 | (let ((map (make-sparse-keymap))) |
| 315 | (suppress-keymap map t) |
| 316 | (mapc |
| 317 | (lambda (c) |
| 318 | (if (listp tmm-shortcut-style) |
| 319 | (define-key map (char-to-string c) 'tmm-shortcut) |
| 320 | ;; only one kind of letters are shortcuts, so map both upcase and |
| 321 | ;; downcase input to the same |
| 322 | (define-key map (char-to-string (downcase c)) 'tmm-shortcut) |
| 323 | (define-key map (char-to-string (upcase c)) 'tmm-shortcut))) |
| 324 | tmm-short-cuts) |
| 325 | (if minibuffer |
| 326 | (progn |
| 327 | (define-key map [pageup] 'tmm-goto-completions) |
| 328 | (define-key map [prior] 'tmm-goto-completions) |
| 329 | (define-key map "\ev" 'tmm-goto-completions) |
| 330 | (define-key map "\C-n" 'next-history-element) |
| 331 | (define-key map "\C-p" 'previous-history-element))) |
| 332 | (prog1 (current-local-map) |
| 333 | (use-local-map (append map (current-local-map)))))) |
| 334 | |
| 335 | (defun tmm-completion-delete-prompt () |
| 336 | (set-buffer standard-output) |
| 337 | (goto-char 1) |
| 338 | (delete-region 1 (search-forward "Possible completions are:\n"))) |
| 339 | |
| 340 | (defun tmm-remove-inactive-mouse-face () |
| 341 | "Remove the mouse-face property from inactive menu items." |
| 342 | (let ((inhibit-read-only t) |
| 343 | (inactive-string |
| 344 | (concat " " (make-string (length tmm-mid-prompt) ?\-))) |
| 345 | next) |
| 346 | (save-excursion |
| 347 | (goto-char (point-min)) |
| 348 | (while (not (eobp)) |
| 349 | (setq next (next-single-char-property-change (point) 'mouse-face)) |
| 350 | (when (looking-at inactive-string) |
| 351 | (remove-text-properties (point) next '(mouse-face)) |
| 352 | (add-text-properties (point) next '(face tmm-inactive))) |
| 353 | (goto-char next))) |
| 354 | (set-buffer-modified-p nil))) |
| 355 | |
| 356 | (defun tmm-add-prompt () |
| 357 | (remove-hook 'minibuffer-setup-hook 'tmm-add-prompt) |
| 358 | (add-hook 'minibuffer-exit-hook 'tmm-delete-map nil t) |
| 359 | (unless tmm-c-prompt |
| 360 | (error "No active menu entries")) |
| 361 | (let ((win (selected-window))) |
| 362 | (setq tmm-old-mb-map (tmm-define-keys t)) |
| 363 | ;; Get window and hide it for electric mode to get correct size |
| 364 | (save-window-excursion |
| 365 | (let ((completions |
| 366 | (mapcar 'car minibuffer-completion-table))) |
| 367 | (or tmm-completion-prompt |
| 368 | (add-hook 'completion-setup-hook |
| 369 | 'tmm-completion-delete-prompt 'append)) |
| 370 | (with-output-to-temp-buffer "*Completions*" |
| 371 | (display-completion-list completions)) |
| 372 | (remove-hook 'completion-setup-hook 'tmm-completion-delete-prompt)) |
| 373 | (set-buffer "*Completions*") |
| 374 | (tmm-remove-inactive-mouse-face) |
| 375 | (when tmm-completion-prompt |
| 376 | (let ((buffer-read-only nil)) |
| 377 | (goto-char (point-min)) |
| 378 | (insert tmm-completion-prompt)))) |
| 379 | (save-selected-window |
| 380 | (other-window 1) ; Electric-pop-up-window does |
| 381 | ; not work in minibuffer |
| 382 | (Electric-pop-up-window "*Completions*") |
| 383 | (with-current-buffer "*Completions*" |
| 384 | (setq tmm-old-comp-map (tmm-define-keys nil)))) |
| 385 | (insert tmm-c-prompt))) |
| 386 | |
| 387 | (defun tmm-delete-map () |
| 388 | (remove-hook 'minibuffer-exit-hook 'tmm-delete-map t) |
| 389 | (if tmm-old-mb-map |
| 390 | (use-local-map tmm-old-mb-map))) |
| 391 | |
| 392 | (defun tmm-shortcut () |
| 393 | "Choose the shortcut that the user typed." |
| 394 | (interactive) |
| 395 | (let ((c last-command-char) s) |
| 396 | (if (symbolp tmm-shortcut-style) |
| 397 | (setq c (funcall tmm-shortcut-style c))) |
| 398 | (if (memq c tmm-short-cuts) |
| 399 | (if (equal (buffer-name) "*Completions*") |
| 400 | (progn |
| 401 | (goto-char (point-min)) |
| 402 | (re-search-forward |
| 403 | (concat "\\(^\\|[ \t]\\)" (char-to-string c) tmm-mid-prompt)) |
| 404 | (choose-completion)) |
| 405 | ;; In minibuffer |
| 406 | (delete-region (minibuffer-prompt-end) (point-max)) |
| 407 | (mapc (lambda (elt) |
| 408 | (if (string= |
| 409 | (substring (car elt) 0 |
| 410 | (min (1+ (length tmm-mid-prompt)) |
| 411 | (length (car elt)))) |
| 412 | (concat (char-to-string c) tmm-mid-prompt)) |
| 413 | (setq s (car elt)))) |
| 414 | tmm-km-list) |
| 415 | (insert s) |
| 416 | (exit-minibuffer))))) |
| 417 | |
| 418 | (defun tmm-goto-completions () |
| 419 | (interactive) |
| 420 | (let ((prompt-end (minibuffer-prompt-end))) |
| 421 | (setq tmm-c-prompt (buffer-substring prompt-end (point-max))) |
| 422 | (delete-region prompt-end (point-max))) |
| 423 | (switch-to-buffer-other-window "*Completions*") |
| 424 | (search-forward tmm-c-prompt) |
| 425 | (search-backward tmm-c-prompt)) |
| 426 | |
| 427 | (defun tmm-get-keymap (elt &optional in-x-menu) |
| 428 | "Prepends (DOCSTRING EVENT BINDING) to free variable `tmm-km-list'. |
| 429 | The values are deduced from the argument ELT, that should be an |
| 430 | element of keymap, an `x-popup-menu' argument, or an element of |
| 431 | `x-popup-menu' argument (when IN-X-MENU is not-nil). |
| 432 | This function adds the element only if it is not already present. |
| 433 | It uses the free variable `tmm-table-undef' to keep undefined keys." |
| 434 | (let (km str cache plist filter visible enable (event (car elt))) |
| 435 | (setq elt (cdr elt)) |
| 436 | (if (eq elt 'undefined) |
| 437 | (setq tmm-table-undef (cons (cons event nil) tmm-table-undef)) |
| 438 | (unless (assoc event tmm-table-undef) |
| 439 | (cond ((if (listp elt) |
| 440 | (or (keymapp elt) (eq (car elt) 'lambda)) |
| 441 | (fboundp elt)) |
| 442 | (setq km elt)) |
| 443 | |
| 444 | ((if (listp (cdr-safe elt)) |
| 445 | (or (keymapp (cdr-safe elt)) |
| 446 | (eq (car (cdr-safe elt)) 'lambda)) |
| 447 | (fboundp (cdr-safe elt))) |
| 448 | (setq km (cdr elt)) |
| 449 | (and (stringp (car elt)) (setq str (car elt)))) |
| 450 | |
| 451 | ((if (listp (cdr-safe (cdr-safe elt))) |
| 452 | (or (keymapp (cdr-safe (cdr-safe elt))) |
| 453 | (eq (car (cdr-safe (cdr-safe elt))) 'lambda)) |
| 454 | (fboundp (cdr-safe (cdr-safe elt)))) |
| 455 | (setq km (cdr (cdr elt))) |
| 456 | (and (stringp (car elt)) (setq str (car elt))) |
| 457 | (and str |
| 458 | (stringp (cdr (car (cdr elt)))) ; keyseq cache |
| 459 | (setq cache (cdr (car (cdr elt)))) |
| 460 | cache (setq str (concat str cache)))) |
| 461 | |
| 462 | ((eq (car-safe elt) 'menu-item) |
| 463 | ;; (menu-item TITLE COMMAND KEY ...) |
| 464 | (setq plist (cdr-safe (cdr-safe (cdr-safe elt)))) |
| 465 | (when (consp (car-safe plist)) |
| 466 | (setq plist (cdr-safe plist))) |
| 467 | (setq km (nth 2 elt)) |
| 468 | (setq str (eval (nth 1 elt))) |
| 469 | (setq filter (plist-get plist :filter)) |
| 470 | (if filter |
| 471 | (setq km (funcall filter km))) |
| 472 | (setq visible (plist-get plist :visible)) |
| 473 | (if visible |
| 474 | (setq km (and (eval visible) km))) |
| 475 | (setq enable (plist-get plist :enable)) |
| 476 | (if enable |
| 477 | (setq km (if (eval enable) km 'ignore))) |
| 478 | (and str |
| 479 | (consp (nth 3 elt)) |
| 480 | (stringp (cdr (nth 3 elt))) ; keyseq cache |
| 481 | (setq cache (cdr (nth 3 elt))) |
| 482 | cache |
| 483 | (setq str (concat str cache)))) |
| 484 | |
| 485 | ((if (listp (cdr-safe (cdr-safe (cdr-safe elt)))) |
| 486 | (or (keymapp (cdr-safe (cdr-safe (cdr-safe elt)))) |
| 487 | (eq (car (cdr-safe (cdr-safe (cdr-safe elt)))) 'lambda)) |
| 488 | (fboundp (cdr-safe (cdr-safe (cdr-safe elt))))) |
| 489 | ; New style of easy-menu |
| 490 | (setq km (cdr (cdr (cdr elt)))) |
| 491 | (and (stringp (car elt)) (setq str (car elt))) |
| 492 | (and str |
| 493 | (stringp (cdr (car (cdr (cdr elt))))) ; keyseq cache |
| 494 | (setq cache (cdr (car (cdr (cdr elt))))) |
| 495 | cache (setq str (concat str cache)))) |
| 496 | |
| 497 | ((stringp event) ; x-popup or x-popup element |
| 498 | (if (or in-x-menu (stringp (car-safe elt))) |
| 499 | (setq str event event nil km elt) |
| 500 | (setq str event event nil km (cons 'keymap elt)) |
| 501 | )))) |
| 502 | (and km (stringp km) (setq str km)) |
| 503 | ;; Verify that the command is enabled; |
| 504 | ;; if not, don't mention it. |
| 505 | (when (and km (symbolp km) (get km 'menu-enable)) |
| 506 | (setq km (if (eval (get km 'menu-enable)) km 'ignore))) |
| 507 | (and km str |
| 508 | (or (assoc str tmm-km-list) |
| 509 | (push (cons str (cons event km)) tmm-km-list)))))) |
| 510 | |
| 511 | (defun tmm-get-keybind (keyseq) |
| 512 | "Return the current binding of KEYSEQ, merging prefix definitions. |
| 513 | If KEYSEQ is a prefix key that has local and global bindings, |
| 514 | we merge them into a single keymap which shows the proper order of the menu. |
| 515 | However, for the menu bar itself, the value does not take account |
| 516 | of `menu-bar-final-items'." |
| 517 | (let (allbind bind) |
| 518 | (setq bind (key-binding keyseq)) |
| 519 | ;; If KEYSEQ is a prefix key, then BIND is either nil |
| 520 | ;; or a symbol defined as a keymap (which satisfies keymapp). |
| 521 | (if (keymapp bind) |
| 522 | (setq bind nil)) |
| 523 | ;; If we have a non-keymap definition, return that. |
| 524 | (or bind |
| 525 | (progn |
| 526 | ;; Otherwise, it is a prefix, so make a list of the subcommands. |
| 527 | ;; Make a list of all the bindings in all the keymaps. |
| 528 | (setq allbind (mapcar 'cdr (minor-mode-key-binding keyseq))) |
| 529 | (setq allbind (cons (local-key-binding keyseq) allbind)) |
| 530 | (setq allbind (cons (global-key-binding keyseq) allbind)) |
| 531 | ;; Merge all the elements of ALLBIND into one keymap. |
| 532 | (mapc (lambda (in) |
| 533 | (if (and (symbolp in) (keymapp in)) |
| 534 | (setq in (symbol-function in))) |
| 535 | (and in (keymapp in) |
| 536 | (if (keymapp bind) |
| 537 | (setq bind (nconc bind (copy-sequence (cdr in)))) |
| 538 | (setq bind (copy-sequence in))))) |
| 539 | allbind) |
| 540 | ;; Return that keymap. |
| 541 | bind)))) |
| 542 | |
| 543 | (add-hook 'calendar-load-hook (lambda () (require 'cal-menu))) |
| 544 | |
| 545 | (provide 'tmm) |
| 546 | |
| 547 | ;;; arch-tag: e7ddbdb6-4b95-4da3-afbe-ad6063d112f4 |
| 548 | ;;; tmm.el ends here |