X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/d2fc7e3d0f6f57f962cbd94df3bf4fd15a37bb68..dec2a322921d74de8f251a54931d4c50ab00713d:/lisp/tmm.el diff --git a/lisp/tmm.el b/lisp/tmm.el index 52704e70a5..cd91742649 100644 --- a/lisp/tmm.el +++ b/lisp/tmm.el @@ -1,6 +1,6 @@ -;;; tmm.el --- text mode access to menu-bar +;;; tmm.el --- text mode access to menu-bar -*- lexical-binding: t -*- -;; Copyright (C) 1994-1996, 2000-2011 Free Software Foundation, Inc. +;; Copyright (C) 1994-1996, 2000-2013 Free Software Foundation, Inc. ;; Author: Ilya Zakharevich ;; Maintainer: FSF @@ -37,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) @@ -55,36 +54,37 @@ we make that menu bar item (the one at that position) the default choice." (interactive) (run-hooks 'menu-bar-update-hook) ;; Obey menu-bar-final-items; put those items last. - (let ((menu-bar (tmm-get-keybind [menu-bar])) + (let ((menu-bar '()) + (menu-end '()) menu-bar-item) - (let ((list menu-bar-final-items)) - (while list - (let ((item (car list))) - ;; ITEM is the name of an item that we want to put last. - ;; Find it in MENU-BAR and move it to the end. - (let ((this-one (assq item menu-bar))) - (setq menu-bar (append (delq this-one menu-bar) - (list this-one))))) - (setq list (cdr list)))) + (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])) + (setq menu-bar `(keymap ,@(nreverse menu-bar) ,@(nreverse menu-end))) (if x-position - (let ((tail menu-bar) (column 0) - this-one name visible) - (while (and tail (<= column x-position)) - (setq this-one (car tail)) - (if (and (consp this-one) - (consp (cdr this-one)) - (setq name ;simple menu - (cond ((stringp (nth 1 this-one)) - (nth 1 this-one)) - ;extended menu - ((stringp (nth 2 this-one)) - (setq visible (plist-get - (nthcdr 4 this-one) :visible)) - (unless (and visible (not (eval visible))) - (nth 2 this-one)))))) - (setq column (+ column (length name) 1))) - (setq tail (cdr tail))) - (setq menu-bar-item (car this-one)))) + (let ((column 0)) + (catch 'done + (map-keymap + (lambda (key binding) + (when (> column x-position) + (setq menu-bar-item key) + (throw 'done nil)) + (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)))) (tmm-prompt menu-bar nil menu-bar-item))) ;;;###autoload @@ -98,7 +98,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) @@ -139,6 +139,12 @@ specify nil for this variable." "Face used for inactive menu items." :group 'tmm) +(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)))) + ;;;###autoload (defun tmm-prompt (menu &optional in-popup default-item) "Text-mode emulation of calling the bindings in keymap. @@ -158,7 +164,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) @@ -166,14 +172,16 @@ Its value should be an event that has a binding in 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. - (mapc (lambda (elt) - (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) + (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)))))) + (setq tmm-km-list (nreverse tmm-km-list)) ;; 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, @@ -219,27 +227,19 @@ 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--completion-table 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)) - (string= (substring out 0 (length tmm-c-prompt)) tmm-c-prompt) + (string-prefix-p tmm-c-prompt out) (setq out (substring out (length tmm-c-prompt)) choice (cdr (assoc out tmm-km-list)))) (and (null choice) out @@ -270,7 +270,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'." @@ -321,15 +321,13 @@ Stores a list of all the shortcuts in the free variable `tmm-short-cuts'." (defun tmm-define-keys (minibuffer) (let ((map (make-sparse-keymap))) (suppress-keymap map t) - (mapc - (lambda (c) - (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))) - tmm-short-cuts) + (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))) (if minibuffer (progn (define-key map [pageup] 'tmm-goto-completions) @@ -341,9 +339,9 @@ Stores a list of all the shortcuts in the free variable `tmm-short-cuts'." (use-local-map (append map (current-local-map)))))) (defun tmm-completion-delete-prompt () - (set-buffer standard-output) + (with-current-buffer standard-output (goto-char (point-min)) - (delete-region (point) (search-forward "Possible completions are:\n"))) + (delete-region (point) (search-forward "Possible completions are:\n")))) (defun tmm-remove-inactive-mouse-face () "Remove the mouse-face property from inactive menu items." @@ -362,41 +360,24 @@ 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")) (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*") + (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*" (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)))) + (let ((inhibit-read-only t)) + (goto-char (point-min)) + (insert tmm-completion-prompt)))) (insert tmm-c-prompt)) -(defun tmm-delete-map () - (remove-hook 'minibuffer-exit-hook 'tmm-delete-map t) - (if tmm-old-mb-map - (use-local-map tmm-old-mb-map))) - (defun tmm-shortcut () "Choose the shortcut that the user typed." (interactive) @@ -412,28 +393,29 @@ Stores a list of all the shortcuts in the free variable `tmm-short-cuts'." (choose-completion)) ;; In minibuffer (delete-region (minibuffer-prompt-end) (point-max)) - (mapc (lambda (elt) - (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)))) - tmm-km-list) + (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)))) (insert s) (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). @@ -460,7 +442,7 @@ It uses the free variable `tmm-table-undef' to keep undefined keys." (or (keymapp (cdr-safe (cdr-safe elt))) (eq (car (cdr-safe (cdr-safe elt))) 'lambda)) (and (symbolp (cdr-safe (cdr-safe elt))) - (fboundp (cdr-safe (cdr-safe elt))))) + (fboundp (cdr-safe (cdr-safe elt))))) (setq km (cddr elt)) (and (stringp (car elt)) (setq str (car elt)))) @@ -486,14 +468,15 @@ It uses the free variable `tmm-table-undef' to keep undefined keys." (eq (car (cdr-safe (cdr-safe (cdr-safe elt)))) 'lambda)) (and (symbolp (cdr-safe (cdr-safe (cdr-safe elt)))) (fboundp (cdr-safe (cdr-safe (cdr-safe elt)))))) - ; New style of easy-menu + ; New style of easy-menu (setq km (cdr (cddr elt))) (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) + (setq event nil) + (setq km (if (or in-x-menu (stringp (car-safe elt))) + elt (cons 'keymap elt))))) (unless (or (eq km 'ignore) (null str)) (let ((binding (where-is-internal km nil t))) (when binding @@ -522,46 +505,7 @@ If KEYSEQ is a prefix key that has local and global bindings, 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'." - (let (allbind bind minorbind localbind globalbind) - (setq bind (key-binding keyseq)) - ;; If KEYSEQ is a prefix key, then BIND is either nil - ;; or a symbol defined as a keymap (which satisfies keymapp). - (if (keymapp bind) - (setq bind nil)) - ;; If we have a non-keymap definition, return that. - (or bind - (progn - ;; Otherwise, it is a prefix, so make a list of the subcommands. - ;; Make a list of all the bindings in all the keymaps. - (setq minorbind (mapcar 'cdr (minor-mode-key-binding keyseq))) - (setq localbind (local-key-binding keyseq)) - (setq globalbind (copy-sequence (cdr (global-key-binding keyseq)))) - - ;; If items have been redefined/undefined locally, remove them from - ;; the global list. - (dolist (minor minorbind) - (dolist (item (cdr minor)) - (setq globalbind (assq-delete-all (car-safe item) globalbind)))) - (dolist (item (cdr localbind)) - (setq globalbind (assq-delete-all (car-safe item) globalbind))) - - (setq globalbind (cons 'keymap globalbind)) - (setq allbind (cons globalbind (cons localbind minorbind))) - - ;; Merge all the elements of ALLBIND into one keymap. - (mapc (lambda (in) - (if (and (symbolp in) (keymapp in)) - (setq in (symbol-function in))) - (and in (keymapp in) - (if (keymapp bind) - (setq bind (nconc bind (copy-sequence (cdr in)))) - (setq bind (copy-sequence in))))) - allbind) - ;; Return that keymap. - bind)))) - -;; Huh? What's that about? --Stef -(add-hook 'calendar-load-hook (lambda () (require 'cal-menu))) + (lookup-key (cons 'keymap (nreverse (current-active-maps))) keyseq)) (provide 'tmm)