-;;; 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-2014 Free Software Foundation, Inc.
;; Author: Ilya Zakharevich <ilya@math.mps.ohio-state.edu>
-;; Maintainer: FSF
+;; Maintainer: emacs-devel@gnu.org
;; Keywords: convenience
;; This file is part of GNU Emacs.
;;; 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)
"Text-mode emulation of looking and choosing from a menubar.
See the documentation for `tmm-prompt'.
X-POSITION, if non-nil, specifies a horizontal position within the menu bar;
-we make that menu bar item (the one at that position) the default choice."
+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
+\`tty-menu-open-use-tmm' to a non-nil value."
(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
(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)
"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))))
+
+(defvar tmm--history nil)
+
;;;###autoload
(defun tmm-prompt (menu &optional in-popup default-item)
"Text-mode emulation of calling the bindings in keymap.
;; 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.
- 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-km-list out history-len tmm-table-undef tmm-c-prompt
+ tmm-old-mb-map tmm-short-cuts
chosen-string choice
(not-menu (not (keymapp menu))))
(run-hooks 'activate-menubar-hook)
;; 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,
(setq index-of-default (1+ index-of-default)))
(setq tail (cdr tail)))))
(let ((prompt (concat "^." (regexp-quote tmm-mid-prompt))))
- (setq history
+ (setq tmm--history
(reverse (delq nil
(mapcar
(lambda (elt)
(if (string-match prompt (car elt))
(car elt)))
tmm-km-list)))))
- (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 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))
+ (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 'tmm--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
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'."
(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)
(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."
(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)
(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).
(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))))
(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
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)
HCoop / bpt / emacs.git / blobdiff