X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/8989a9203f73473569ddf83e505a846609def407..d59e75c81780dc6bd6ea54cc5a621d485df27072:/lisp/tmm.el diff --git a/lisp/tmm.el b/lisp/tmm.el index 7058f54ef8..2a0d1d3d7d 100644 --- a/lisp/tmm.el +++ b/lisp/tmm.el @@ -1,7 +1,6 @@ ;;; tmm.el --- text mode access to menu-bar -;; Copyright (C) 1994, 1995, 1996, 2000, 2001, 2002, 2003, -;; 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. +;; Copyright (C) 1994-1996, 2000-2012 Free Software Foundation, Inc. ;; Author: Ilya Zakharevich ;; Maintainer: FSF @@ -38,7 +37,6 @@ ;;; The following will be localized, added only to pacify the compiler. (defvar tmm-short-cuts) (defvar tmm-old-mb-map nil) -(defvar tmm-old-comp-map) (defvar tmm-c-prompt nil) (defvar tmm-km-list) (defvar tmm-next-shortcut-digit) @@ -99,7 +97,7 @@ See the documentation for `tmm-prompt'." (defcustom tmm-mid-prompt "==>" "String to insert between shortcut and menu item. -If nil, there will be no shortcuts. It should not consist only of spaces, +If nil, there will be no shortcuts. It should not consist only of spaces, or else the correct item might not be found in the `*Completions*' buffer." :type 'string :group 'tmm) @@ -159,7 +157,7 @@ Its value should be an event that has a binding in MENU." (let ((gl-str "Menu bar") ;; The menu bar itself is not a menu keymap ; so it doesn't have a name. tmm-km-list out history history-len tmm-table-undef tmm-c-prompt - tmm-old-mb-map tmm-old-comp-map tmm-short-cuts + tmm-old-mb-map tmm-short-cuts chosen-string choice (not-menu (not (keymapp menu)))) (run-hooks 'activate-menubar-hook) @@ -168,10 +166,13 @@ Its value should be an event that has a binding in MENU." ;; It has no other elements. ;; The order of elements in tmm-km-list is the order of the menu bar. (mapc (lambda (elt) - (if (stringp elt) - (setq gl-str elt) - (and (listp elt) (tmm-get-keymap elt not-menu)))) - 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))))) + menu) ;; 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, @@ -217,23 +218,16 @@ Its value should be an event that has a binding in MENU." (setq history-len (length history)) (setq history (append history history history history)) (setq tmm-c-prompt (nth (- history-len 1 index-of-default) history)) - (add-hook 'minibuffer-setup-hook 'tmm-add-prompt) - (if default-item - (setq out (car (nth index-of-default tmm-km-list))) - (save-excursion - (unwind-protect - (setq out - (completing-read - (concat gl-str - " (up/down to change, PgUp to menu): ") - tmm-km-list nil t nil - (cons 'history - (- (* 2 history-len) index-of-default)))) - (remove-hook 'minibuffer-setup-hook 'tmm-add-prompt) - (if (get-buffer "*Completions*") - (with-current-buffer "*Completions*" - (use-local-map tmm-old-comp-map) - (bury-buffer (current-buffer))))))))) + (setq out + (if default-item + (car (nth index-of-default tmm-km-list)) + (minibuffer-with-setup-hook #'tmm-add-prompt + (completing-read + (concat gl-str + " (up/down to change, PgUp to menu): ") + tmm-km-list nil t nil + (cons 'history + (- (* 2 history-len) index-of-default)))))))) (setq choice (cdr (assoc out tmm-km-list))) (and (null choice) (> (length out) (length tmm-c-prompt)) @@ -258,9 +252,6 @@ Its value should be an event that has a binding in MENU." (condition-case nil (require 'mouse) (error nil)) - (condition-case nil - (x-popup-menu nil choice) ; Get the shortcuts - (error nil)) (tmm-prompt choice)) ;; We just handled a menu keymap and found a command. (choice @@ -271,7 +262,7 @@ Its value should be an event that has a binding in MENU." choice))))) (defun tmm-add-shortcuts (list) - "Adds shortcuts to cars of elements of the list. + "Add shortcuts to cars of elements of the list. Takes a list of lists with a string as car, returns list with shortcuts added to these cars. Stores a list of all the shortcuts in the free variable `tmm-short-cuts'." @@ -363,36 +354,32 @@ Stores a list of all the shortcuts in the free variable `tmm-short-cuts'." (set-buffer-modified-p nil))) (defun tmm-add-prompt () - (remove-hook 'minibuffer-setup-hook 'tmm-add-prompt) (add-hook 'minibuffer-exit-hook 'tmm-delete-map nil t) (unless tmm-c-prompt (error "No active menu entries")) - (let ((win (selected-window))) - (setq tmm-old-mb-map (tmm-define-keys t)) - ;; Get window and hide it for electric mode to get correct size - (save-window-excursion - (let ((completions - (mapcar 'car minibuffer-completion-table))) - (or tmm-completion-prompt - (add-hook 'completion-setup-hook - 'tmm-completion-delete-prompt 'append)) - (unwind-protect - (with-output-to-temp-buffer "*Completions*" - (display-completion-list completions)) - (remove-hook 'completion-setup-hook 'tmm-completion-delete-prompt))) - (set-buffer "*Completions*") - (tmm-remove-inactive-mouse-face) - (when tmm-completion-prompt - (let ((buffer-read-only nil)) - (goto-char (point-min)) - (insert tmm-completion-prompt)))) - (save-selected-window - (other-window 1) ; Electric-pop-up-window does + (setq tmm-old-mb-map (tmm-define-keys t)) + ;; Get window and hide it for electric mode to get correct size + (save-window-excursion + (let ((completions + (mapcar 'car minibuffer-completion-table))) + (or tmm-completion-prompt + (add-hook 'completion-setup-hook + 'tmm-completion-delete-prompt 'append)) + (unwind-protect + (with-output-to-temp-buffer "*Completions*" + (display-completion-list completions)) + (remove-hook 'completion-setup-hook 'tmm-completion-delete-prompt))) + (set-buffer "*Completions*") + (tmm-remove-inactive-mouse-face) + (when tmm-completion-prompt + (let ((buffer-read-only nil)) + (goto-char (point-min)) + (insert tmm-completion-prompt)))) + (save-selected-window + (other-window 1) ; Electric-pop-up-window does ; not work in minibuffer - (Electric-pop-up-window "*Completions*") - (with-current-buffer "*Completions*" - (setq tmm-old-comp-map (tmm-define-keys nil)))) - (insert tmm-c-prompt))) + (Electric-pop-up-window "*Completions*")) + (insert tmm-c-prompt)) (defun tmm-delete-map () (remove-hook 'minibuffer-exit-hook 'tmm-delete-map t) @@ -426,48 +413,47 @@ Stores a list of all the shortcuts in the free variable `tmm-short-cuts'." (exit-minibuffer))))) (defun tmm-goto-completions () + "Jump to the completions buffer." (interactive) (let ((prompt-end (minibuffer-prompt-end))) (setq tmm-c-prompt (buffer-substring prompt-end (point-max))) + ;; FIXME: Why? (delete-region prompt-end (point-max))) (switch-to-buffer-other-window "*Completions*") (search-forward tmm-c-prompt) (search-backward tmm-c-prompt)) (defun tmm-get-keymap (elt &optional in-x-menu) - "Prepends (DOCSTRING EVENT BINDING) to free variable `tmm-km-list'. + "Prepend (DOCSTRING EVENT BINDING) to free variable `tmm-km-list'. The values are deduced from the argument ELT, that should be an element of keymap, an `x-popup-menu' argument, or an element of `x-popup-menu' argument (when IN-X-MENU is not-nil). This function adds the element only if it is not already present. It uses the free variable `tmm-table-undef' to keep undefined keys." - (let (km str cache plist filter visible enable (event (car elt))) + (let (km str plist filter visible enable (event (car elt))) (setq elt (cdr elt)) (if (eq elt 'undefined) (setq tmm-table-undef (cons (cons event nil) tmm-table-undef)) (unless (assoc event tmm-table-undef) (cond ((if (listp elt) (or (keymapp elt) (eq (car elt) 'lambda)) - (fboundp elt)) + (and (symbolp elt) (fboundp elt))) (setq km elt)) ((if (listp (cdr-safe elt)) (or (keymapp (cdr-safe elt)) (eq (car (cdr-safe elt)) 'lambda)) - (fboundp (cdr-safe elt))) + (and (symbolp (cdr-safe elt)) (fboundp (cdr-safe elt)))) (setq km (cdr elt)) (and (stringp (car elt)) (setq str (car elt)))) ((if (listp (cdr-safe (cdr-safe elt))) (or (keymapp (cdr-safe (cdr-safe elt))) (eq (car (cdr-safe (cdr-safe elt))) 'lambda)) - (fboundp (cdr-safe (cdr-safe elt)))) + (and (symbolp (cdr-safe (cdr-safe elt))) + (fboundp (cdr-safe (cdr-safe elt))))) (setq km (cddr elt)) - (and (stringp (car elt)) (setq str (car elt))) - (and str - (stringp (cdr-safe (cadr elt))) ; keyseq cache - (setq cache (cdr (cadr elt))) - cache (setq str (concat str cache)))) + (and (stringp (car elt)) (setq str (car elt)))) ((eq (car-safe elt) 'menu-item) ;; (menu-item TITLE COMMAND KEY ...) @@ -484,30 +470,34 @@ It uses the free variable `tmm-table-undef' to keep undefined keys." (setq km (and (eval visible) km))) (setq enable (plist-get plist :enable)) (if enable - (setq km (if (eval enable) km 'ignore))) - (and str - (consp (nth 3 elt)) - (stringp (cdr (nth 3 elt))) ; keyseq cache - (setq cache (cdr (nth 3 elt))) - cache - (setq str (concat str cache)))) + (setq km (if (eval enable) km 'ignore)))) ((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)) - (fboundp (cdr-safe (cdr-safe (cdr-safe elt))))) + (and (symbolp (cdr-safe (cdr-safe (cdr-safe elt)))) + (fboundp (cdr-safe (cdr-safe (cdr-safe elt)))))) ; New style of easy-menu (setq km (cdr (cddr elt))) - (and (stringp (car elt)) (setq str (car elt))) - (and str - (stringp (cdr-safe (car (cddr elt)))) ; keyseq cache - (setq cache (cdr (car (cdr (cdr elt))))) - cache (setq str (concat str cache)))) + (and (stringp (car elt)) (setq str (car elt)))) ((stringp event) ; x-popup or x-popup element (if (or in-x-menu (stringp (car-safe elt))) (setq str event event nil km elt) - (setq str event event nil km (cons 'keymap elt)))))) + (setq str event event nil km (cons 'keymap elt))))) + (unless (or (eq km 'ignore) (null str)) + (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))))))) (and km (stringp km) (setq str km)) ;; Verify that the command is enabled; ;; if not, don't mention it. @@ -566,5 +556,4 @@ of `menu-bar-final-items'." (provide 'tmm) -;; arch-tag: e7ddbdb6-4b95-4da3-afbe-ad6063d112f4 ;;; tmm.el ends here