* lisp/mail/sendmail.el (mail-position-on-field): Doc fix.
[emacs.git] / lisp / tmm.el
Commit [+]AuthorDateLineData
4d0463b9 Stefan Monnier2013-02-13 08:40:00 -05001;;; tmm.el --- text mode access to menu-bar -*- lexical-binding: t -*-
20062d6b Richard M. Stallman1995-03-11 03:57:25 +00002
7e09ef09 Paul Eggert2015-01-01 14:26:41 -08003;; Copyright (C) 1994-1996, 2000-2015 Free Software Foundation, Inc.
20062d6b
RS
Richard M. Stallman1995-03-11 03:57:25 +00004
5;; Author: Ilya Zakharevich <ilya@math.mps.ohio-state.edu>
34dc21db Glenn Morris2014-02-09 17:34:22 -08006;; Maintainer: emacs-devel@gnu.org
97895167 Pavel Janík2002-01-27 11:17:06 +00007;; Keywords: convenience
20062d6b Richard M. Stallman1995-03-11 03:57:25 +00008
d440e474 Richard M. Stallman1995-03-11 03:58:31 +00009;; This file is part of GNU Emacs.
20062d6b Richard M. Stallman1995-03-11 03:57:25 +000010
eb3fa2cf Glenn Morris2008-05-06 08:06:51 +000011;; GNU Emacs is free software: you can redistribute it and/or modify
20062d6b Richard M. Stallman1995-03-11 03:57:25 +000012;; it under the terms of the GNU General Public License as published by
eb3fa2cf
GM
Glenn Morris2008-05-06 08:06:51 +000013;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
20062d6b
RS
Richard M. Stallman1995-03-11 03:57:25 +000015
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
eb3fa2cf Glenn Morris2008-05-06 08:06:51 +000022;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
20062d6b Richard M. Stallman1995-03-11 03:57:25 +000023
b578f267 Erik Naggum1996-01-14 07:34:30 +000024;;; Commentary:
20062d6b Richard M. Stallman1995-03-11 03:57:25 +000025
97895167 Pavel Janík2002-01-27 11:17:06 +000026;; This package provides text mode access to the menu bar.
20062d6b Richard M. Stallman1995-03-11 03:57:25 +000027
b578f267 Erik Naggum1996-01-14 07:34:30 +000028;;; Code:
20062d6b
RS
Richard M. Stallman1995-03-11 03:57:25 +000029
30(require 'electric)
20062d6b Richard M. Stallman1995-03-11 03:57:25 +000031
4bef9110
SE
Stephen Eglen1998-03-07 18:19:38 +000032(defgroup tmm nil
33 "Text mode access to menu-bar."
34 :prefix "tmm-"
35 :group 'menu)
36
20062d6b
RS
Richard M. Stallman1995-03-11 03:57:25 +000037;;; The following will be localized, added only to pacify the compiler.
38(defvar tmm-short-cuts)
fc225f66 Richard M. Stallman1995-10-30 16:33:49 +000039(defvar tmm-old-mb-map nil)
93253b0e Nick Roberts2007-04-03 01:07:41 +000040(defvar tmm-c-prompt nil)
20062d6b Richard M. Stallman1995-03-11 03:57:25 +000041(defvar tmm-km-list)
670ce6ea Richard M. Stallman1996-09-01 19:47:48 +000042(defvar tmm-next-shortcut-digit)
20062d6b
RS
Richard M. Stallman1995-03-11 03:57:25 +000043(defvar tmm-table-undef)
44
e6a5c7de Richard M. Stallman1995-08-28 00:15:59 +000045;;;###autoload (define-key global-map "\M-`" 'tmm-menubar)
77cc5db0 Richard M. Stallman1996-01-02 05:59:20 +000046;;;###autoload (define-key global-map [menu-bar mouse-1] 'tmm-menubar-mouse)
afb1835e Richard M. Stallman1995-08-03 17:39:53 +000047
20062d6b Richard M. Stallman1995-03-11 03:57:25 +000048;;;###autoload
77cc5db0 Richard M. Stallman1996-01-02 05:59:20 +000049(defun tmm-menubar (&optional x-position)
20062d6b Richard M. Stallman1995-03-11 03:57:25 +000050 "Text-mode emulation of looking and choosing from a menubar.
77cc5db0
RS
Richard M. Stallman1996-01-02 05:59:20 +000051See the documentation for `tmm-prompt'.
52X-POSITION, if non-nil, specifies a horizontal position within the menu bar;
493a1978
EZ
Eli Zaretskii2013-10-08 12:01:26 +030053we make that menu bar item (the one at that position) the default choice.
54
55Note that \\[menu-bar-open] by default drops down TTY menus; if you want it
56to invoke `tmm-menubar' instead, customize the variable
57\`tty-menu-open-use-tmm' to a non-nil value."
20062d6b
RS
Richard M. Stallman1995-03-11 03:57:25 +000058 (interactive)
59 (run-hooks 'menu-bar-update-hook)
fc225f66 Richard M. Stallman1995-10-30 16:33:49 +000060 ;; Obey menu-bar-final-items; put those items last.
4d0463b9
SM
Stefan Monnier2013-02-13 08:40:00 -050061 (let ((menu-bar '())
62 (menu-end '())
77cc5db0 Richard M. Stallman1996-01-02 05:59:20 +000063 menu-bar-item)
4d0463b9
SM
Stefan Monnier2013-02-13 08:40:00 -050064 (map-keymap
65 (lambda (key binding)
66 (push (cons key binding)
67 ;; If KEY is the name of an item that we want to put last,
68 ;; move it to the end.
69 (if (memq key menu-bar-final-items)
70 menu-end
71 menu-bar)))
72 (tmm-get-keybind [menu-bar]))
73 (setq menu-bar `(keymap ,@(nreverse menu-bar) ,@(nreverse menu-end)))
77cc5db0 Richard M. Stallman1996-01-02 05:59:20 +000074 (if x-position
4d0463b9
SM
Stefan Monnier2013-02-13 08:40:00 -050075 (let ((column 0))
76 (catch 'done
77 (map-keymap
78 (lambda (key binding)
79 (when (> column x-position)
80 (setq menu-bar-item key)
81 (throw 'done nil))
82 (pcase binding
83 ((or `(,(and (pred stringp) name) . ,_) ;Simple menu item.
84 `(menu-item ,name ,_cmd ;Extended menu item.
85 . ,(and props
86 (guard (let ((visible
87 (plist-get props :visible)))
88 (or (null visible)
89 (eval visible)))))))
90 (setq column (+ column (length name) 1)))))
91 menu-bar))))
77cc5db0
RS
Richard M. Stallman1996-01-02 05:59:20 +000092 (tmm-prompt menu-bar nil menu-bar-item)))
93
8e735883 Karl Heuer1996-01-09 23:20:11 +000094;;;###autoload
77cc5db0
RS
Richard M. Stallman1996-01-02 05:59:20 +000095(defun tmm-menubar-mouse (event)
96 "Text-mode emulation of looking and choosing from a menubar.
97This command is used when you click the mouse in the menubar
98on a console which has no window system but does have a mouse.
99See the documentation for `tmm-prompt'."
100 (interactive "e")
101 (tmm-menubar (car (posn-x-y (event-start event)))))
20062d6b Richard M. Stallman1995-03-11 03:57:25 +0000102
4bef9110 Stephen Eglen1998-03-07 18:19:38 +0000103(defcustom tmm-mid-prompt "==>"
c03aab72 Stefan Monnier2007-09-10 03:46:53 +0000104 "String to insert between shortcut and menu item.
3ae704f4 Stefan Monnier2011-11-15 21:26:00 -0500105If nil, there will be no shortcuts. It should not consist only of spaces,
4bef9110
SE
Stephen Eglen1998-03-07 18:19:38 +0000106or else the correct item might not be found in the `*Completions*' buffer."
107 :type 'string
108 :group 'tmm)
20062d6b
RS
Richard M. Stallman1995-03-11 03:57:25 +0000109
110(defvar tmm-mb-map nil
111 "A place to store minibuffer map.")
112
97895167 Pavel Janík2002-01-27 11:17:06 +0000113(defcustom tmm-completion-prompt
e5ba1eb9 Pavel Janík2002-04-22 15:30:18 +0000114 "Press PageUp key to reach this buffer from the minibuffer.
20062d6b Richard M. Stallman1995-03-11 03:57:25 +0000115Alternatively, you can use Up/Down keys (or your History keys) to change
97895167 Pavel Janík2002-01-27 11:17:06 +0000116the item in the minibuffer, and press RET when you are done, or press the
10fe2d38 Richard M. Stallman1995-11-13 03:20:37 +0000117marked letters to pick up your choice. Type C-g or ESC ESC ESC to cancel.
20062d6b Richard M. Stallman1995-03-11 03:57:25 +0000118"
c03aab72 Stefan Monnier2007-09-10 03:46:53 +0000119 "Help text to insert on the top of the completion buffer.
670ce6ea Richard M. Stallman1996-09-01 19:47:48 +0000120To save space, you can set this to nil,
4bef9110
SE
Stephen Eglen1998-03-07 18:19:38 +0000121in which case the standard introduction text is deleted too."
122 :type '(choice string (const nil))
123 :group 'tmm)
670ce6ea Richard M. Stallman1996-09-01 19:47:48 +0000124
4bef9110 Stephen Eglen1998-03-07 18:19:38 +0000125(defcustom tmm-shortcut-style '(downcase upcase)
c03aab72 Stefan Monnier2007-09-10 03:46:53 +0000126 "What letters to use as menu shortcuts.
97895167 Pavel Janík2002-01-27 11:17:06 +0000127Must be either one of the symbols `downcase' or `upcase',
4bef9110
SE
Stephen Eglen1998-03-07 18:19:38 +0000128or else a list of the two in the order you prefer."
129 :type '(choice (const downcase)
130 (const upcase)
131 (repeat (choice (const downcase) (const upcase))))
132 :group 'tmm)
670ce6ea Richard M. Stallman1996-09-01 19:47:48 +0000133
4bef9110 Stephen Eglen1998-03-07 18:19:38 +0000134(defcustom tmm-shortcut-words 2
c03aab72 Stefan Monnier2007-09-10 03:46:53 +0000135 "How many successive words to try for shortcuts, nil means all.
97895167 Pavel Janík2002-01-27 11:17:06 +0000136If you use only one of `downcase' or `upcase' for `tmm-shortcut-style',
4bef9110
SE
Stephen Eglen1998-03-07 18:19:38 +0000137specify nil for this variable."
138 :type '(choice integer (const nil))
139 :group 'tmm)
20062d6b Richard M. Stallman1995-03-11 03:57:25 +0000140
e43cbeae Juri Linkov2005-06-06 16:28:26 +0000141(defface tmm-inactive
1c8c1295 Juri Linkov2005-06-06 12:24:51 +0000142 '((t :inherit shadow))
04a5d30f
NR
Nick Roberts2005-06-03 11:24:06 +0000143 "Face used for inactive menu items."
144 :group 'tmm)
145
4d0463b9
SM
Stefan Monnier2013-02-13 08:40:00 -0500146(defun tmm--completion-table (items)
147 (lambda (string pred action)
148 (if (eq action 'metadata)
149 '(metadata (display-sort-function . identity))
150 (complete-with-action action items string pred))))
151
7a550bbb
GM
Glenn Morris2013-10-16 14:23:15 -0400152(defvar tmm--history nil)
153
20062d6b Richard M. Stallman1995-03-11 03:57:25 +0000154;;;###autoload
bdbc7685 Richard M. Stallman1996-01-02 06:35:43 +0000155(defun tmm-prompt (menu &optional in-popup default-item)
20062d6b Richard M. Stallman1995-03-11 03:57:25 +0000156 "Text-mode emulation of calling the bindings in keymap.
77cc5db0
RS
Richard M. Stallman1996-01-02 05:59:20 +0000157Creates a text-mode menu of possible choices. You can access the elements
158in the menu in two ways:
159 *) via history mechanism from minibuffer;
20062d6b
RS
Richard M. Stallman1995-03-11 03:57:25 +0000160 *) Or via completion-buffer that is automatically shown.
161The last alternative is currently a hack, you cannot use mouse reliably.
bdbc7685
RS
Richard M. Stallman1996-01-02 06:35:43 +0000162
163MENU is like the MENU argument to `x-popup-menu': either a
164keymap or an alist of alists.
165DEFAULT-ITEM, if non-nil, specifies an initial default choice.
166Its value should be an event that has a binding in MENU."
167 ;; If the optional argument IN-POPUP is t,
168 ;; then MENU is an alist of elements of the form (STRING . VALUE).
169 ;; That is used for recursive calls only.
170 (let ((gl-str "Menu bar") ;; The menu bar itself is not a menu keymap
171 ; so it doesn't have a name.
7a550bbb Glenn Morris2013-10-16 14:23:15 -0400172 tmm-km-list out history-len tmm-table-undef tmm-c-prompt
3ae704f4 Stefan Monnier2011-11-15 21:26:00 -0500173 tmm-old-mb-map tmm-short-cuts
bdbc7685
RS
Richard M. Stallman1996-01-02 06:35:43 +0000174 chosen-string choice
175 (not-menu (not (keymapp menu))))
20062d6b Richard M. Stallman1995-03-11 03:57:25 +0000176 (run-hooks 'activate-menubar-hook)
bdbc7685
RS
Richard M. Stallman1996-01-02 06:35:43 +0000177 ;; Compute tmm-km-list from MENU.
178 ;; tmm-km-list is an alist of (STRING . MEANING).
179 ;; It has no other elements.
180 ;; The order of elements in tmm-km-list is the order of the menu bar.
70edffb1
SM
Stefan Monnier2012-10-28 10:56:51 -0400181 (if (not not-menu)
182 (map-keymap (lambda (k v) (tmm-get-keymap (cons k v))) menu)
183 (dolist (elt menu)
184 (cond
185 ((stringp elt) (setq gl-str elt))
186 ((listp elt) (tmm-get-keymap elt not-menu))
187 ((vectorp elt)
188 (dotimes (i (length elt))
189 (tmm-get-keymap (cons i (aref elt i)) not-menu))))))
4d0463b9 Stefan Monnier2013-02-13 08:40:00 -0500190 (setq tmm-km-list (nreverse tmm-km-list))
bdbc7685
RS
Richard M. Stallman1996-01-02 06:35:43 +0000191 ;; Choose an element of tmm-km-list; put it in choice.
192 (if (and not-menu (= 1 (length tmm-km-list)))
193 ;; If this is the top-level of an x-popup-menu menu,
194 ;; and there is just one pane, choose that one silently.
195 ;; This way we only ask the user one question,
196 ;; for which element of that pane.
197 (setq choice (cdr (car tmm-km-list)))
ae3f2f3c
RS
Richard M. Stallman1998-04-21 04:51:23 +0000198 (unless tmm-km-list
199 (error "Empty menu reached"))
bdbc7685
RS
Richard M. Stallman1996-01-02 06:35:43 +0000200 (and tmm-km-list
201 (let ((index-of-default 0))
202 (if tmm-mid-prompt
203 (setq tmm-km-list (tmm-add-shortcuts tmm-km-list))
204 t)
205 ;; Find the default item's index within the menu bar.
206 ;; We use this to decide the initial minibuffer contents
207 ;; and initial history position.
208 (if default-item
a4e03d18 Nick Roberts2007-04-03 10:09:45 +0000209 (let ((tail menu) visible)
bdbc7685
RS
Richard M. Stallman1996-01-02 06:35:43 +0000210 (while (and tail
211 (not (eq (car-safe (car tail)) default-item)))
212 ;; Be careful to count only the elements of MENU
213 ;; that actually constitute menu bar items.
214 (if (and (consp (car tail))
d0bca3c9 Gerd Moellmann2000-05-29 15:50:01 +0000215 (or (stringp (car-safe (cdr (car tail))))
a4e03d18
NR
Nick Roberts2007-04-03 10:09:45 +0000216 (and
217 (eq (car-safe (cdr (car tail))) 'menu-item)
218 (progn
219 (setq visible
220 (plist-get
221 (nthcdr 4 (car tail)) :visible))
222 (or (not visible) (eval visible))))))
bdbc7685
RS
Richard M. Stallman1996-01-02 06:35:43 +0000223 (setq index-of-default (1+ index-of-default)))
224 (setq tail (cdr tail)))))
04a5d30f Nick Roberts2005-06-03 11:24:06 +0000225 (let ((prompt (concat "^." (regexp-quote tmm-mid-prompt))))
7a550bbb Glenn Morris2013-10-16 14:23:15 -0400226 (setq tmm--history
04a5d30f
NR
Nick Roberts2005-06-03 11:24:06 +0000227 (reverse (delq nil
228 (mapcar
229 (lambda (elt)
230 (if (string-match prompt (car elt))
231 (car elt)))
232 tmm-km-list)))))
7a550bbb
GM
Glenn Morris2013-10-16 14:23:15 -0400233 (setq history-len (length tmm--history))
234 (setq tmm--history (append tmm--history tmm--history
235 tmm--history tmm--history))
236 (setq tmm-c-prompt (nth (- history-len 1 index-of-default)
237 tmm--history))
3ae704f4
SM
Stefan Monnier2011-11-15 21:26:00 -0500238 (setq out
239 (if default-item
240 (car (nth index-of-default tmm-km-list))
241 (minibuffer-with-setup-hook #'tmm-add-prompt
242 (completing-read
243 (concat gl-str
244 " (up/down to change, PgUp to menu): ")
4d0463b9 Stefan Monnier2013-02-13 08:40:00 -0500245 (tmm--completion-table tmm-km-list) nil t nil
7a550bbb Glenn Morris2013-10-16 14:23:15 -0400246 (cons 'tmm--history
3ae704f4 Stefan Monnier2011-11-15 21:26:00 -0500247 (- (* 2 history-len) index-of-default))))))))
bdbc7685
RS
Richard M. Stallman1996-01-02 06:35:43 +0000248 (setq choice (cdr (assoc out tmm-km-list)))
249 (and (null choice)
7287f2f3 Stefan Monnier2012-06-07 12:35:00 -0400250 (string-prefix-p tmm-c-prompt out)
bdbc7685
RS
Richard M. Stallman1996-01-02 06:35:43 +0000251 (setq out (substring out (length tmm-c-prompt))
252 choice (cdr (assoc out tmm-km-list))))
ae3f2f3c Richard M. Stallman1998-04-21 04:51:23 +0000253 (and (null choice) out
bdbc7685
RS
Richard M. Stallman1996-01-02 06:35:43 +0000254 (setq out (try-completion out tmm-km-list)
255 choice (cdr (assoc out tmm-km-list)))))
256 ;; CHOICE is now (STRING . MEANING). Separate the two parts.
257 (setq chosen-string (car choice))
258 (setq choice (cdr choice))
259 (cond (in-popup
260 ;; We just did the inner level of a -popup menu.
261 choice)
262 ;; We just did the outer level. Do the inner level now.
97895167 Pavel Janík2002-01-27 11:17:06 +0000263 (not-menu (tmm-prompt choice t))
bdbc7685
RS
Richard M. Stallman1996-01-02 06:35:43 +0000264 ;; We just handled a menu keymap and found another keymap.
265 ((keymapp choice)
266 (if (symbolp choice)
267 (setq choice (indirect-function choice)))
268 (condition-case nil
269 (require 'mouse)
270 (error nil))
bdbc7685
RS
Richard M. Stallman1996-01-02 06:35:43 +0000271 (tmm-prompt choice))
272 ;; We just handled a menu keymap and found a command.
273 (choice
274 (if chosen-string
3132f319
KH
Karl Heuer1996-01-24 21:59:32 +0000275 (progn
276 (setq last-command-event chosen-string)
277 (call-interactively choice))
bdbc7685 Richard M. Stallman1996-01-02 06:35:43 +0000278 choice)))))
20062d6b Richard M. Stallman1995-03-11 03:57:25 +0000279
20062d6b Richard M. Stallman1995-03-11 03:57:25 +0000280(defun tmm-add-shortcuts (list)
3ae704f4 Stefan Monnier2011-11-15 21:26:00 -0500281 "Add shortcuts to cars of elements of the list.
20062d6b Richard M. Stallman1995-03-11 03:57:25 +0000282Takes a list of lists with a string as car, returns list with
fc225f66
RS
Richard M. Stallman1995-10-30 16:33:49 +0000283shortcuts added to these cars.
284Stores a list of all the shortcuts in the free variable `tmm-short-cuts'."
670ce6ea
RS
Richard M. Stallman1996-09-01 19:47:48 +0000285 (let ((tmm-next-shortcut-digit ?0))
286 (mapcar 'tmm-add-one-shortcut (reverse list))))
20062d6b Richard M. Stallman1995-03-11 03:57:25 +0000287
670ce6ea
RS
Richard M. Stallman1996-09-01 19:47:48 +0000288(defsubst tmm-add-one-shortcut (elt)
289;; uses the free vars tmm-next-shortcut-digit and tmm-short-cuts
04a5d30f
NR
Nick Roberts2005-06-03 11:24:06 +0000290 (cond
291 ((eq (cddr elt) 'ignore)
292 (cons (concat " " (make-string (length tmm-mid-prompt) ?\-)
293 (car elt))
294 (cdr elt)))
295 (t
296 (let* ((str (car elt))
297 (paren (string-match "(" str))
298 (pos 0) (word 0) char)
299 (catch 'done ; ??? is this slow?
300 (while (and (or (not tmm-shortcut-words) ; no limit on words
301 (< word tmm-shortcut-words)) ; try n words
302 (setq pos (string-match "\\w+" str pos)) ; get next word
303 (not (and paren (> pos paren)))) ; don't go past "(binding.."
304 (if (or (= pos 0)
305 (/= (aref str (1- pos)) ?.)) ; avoid file extensions
306 (let ((shortcut-style
307 (if (listp tmm-shortcut-style) ; convert to list
308 tmm-shortcut-style
309 (list tmm-shortcut-style))))
310 (while shortcut-style ; try upcase and downcase variants
311 (setq char (funcall (car shortcut-style) (aref str pos)))
312 (if (not (memq char tmm-short-cuts)) (throw 'done char))
313 (setq shortcut-style (cdr shortcut-style)))))
314 (setq word (1+ word))
315 (setq pos (match-end 0)))
316 (while (<= tmm-next-shortcut-digit ?9) ; no letter shortcut, pick a digit
317 (setq char tmm-next-shortcut-digit)
318 (setq tmm-next-shortcut-digit (1+ tmm-next-shortcut-digit))
319 (if (not (memq char tmm-short-cuts)) (throw 'done char)))
320 (setq char nil))
321 (if char (setq tmm-short-cuts (cons char tmm-short-cuts)))
322 (cons (concat (if char (concat (char-to-string char) tmm-mid-prompt)
323 ;; keep them lined up in columns
a322861f Juanma Barranquero2006-11-27 14:12:34 +0000324 (make-string (1+ (length tmm-mid-prompt)) ?\s))
04a5d30f
NR
Nick Roberts2005-06-03 11:24:06 +0000325 str)
326 (cdr elt))))))
670ce6ea
RS
Richard M. Stallman1996-09-01 19:47:48 +0000327
328;; This returns the old map.
fe03654a Richard M. Stallman1996-03-28 18:16:43 +0000329(defun tmm-define-keys (minibuffer)
670ce6ea
RS
Richard M. Stallman1996-09-01 19:47:48 +0000330 (let ((map (make-sparse-keymap)))
331 (suppress-keymap map t)
a2754b6c
SM
Stefan Monnier2012-04-10 16:12:07 -0400332 (dolist (c tmm-short-cuts)
333 (if (listp tmm-shortcut-style)
334 (define-key map (char-to-string c) 'tmm-shortcut)
335 ;; only one kind of letters are shortcuts, so map both upcase and
336 ;; downcase input to the same
337 (define-key map (char-to-string (downcase c)) 'tmm-shortcut)
338 (define-key map (char-to-string (upcase c)) 'tmm-shortcut)))
670ce6ea
RS
Richard M. Stallman1996-09-01 19:47:48 +0000339 (if minibuffer
340 (progn
341 (define-key map [pageup] 'tmm-goto-completions)
342 (define-key map [prior] 'tmm-goto-completions)
343 (define-key map "\ev" 'tmm-goto-completions)
344 (define-key map "\C-n" 'next-history-element)
345 (define-key map "\C-p" 'previous-history-element)))
346 (prog1 (current-local-map)
347 (use-local-map (append map (current-local-map))))))
348
349(defun tmm-completion-delete-prompt ()
7287f2f3 Stefan Monnier2012-06-07 12:35:00 -0400350 (with-current-buffer standard-output
9241efbe Stefan Monnier2008-04-14 18:13:16 +0000351 (goto-char (point-min))
7287f2f3 Stefan Monnier2012-06-07 12:35:00 -0400352 (delete-region (point) (search-forward "Possible completions are:\n"))))
b46324e6 Richard M. Stallman1995-11-10 17:29:36 +0000353
04a5d30f
NR
Nick Roberts2005-06-03 11:24:06 +0000354(defun tmm-remove-inactive-mouse-face ()
355 "Remove the mouse-face property from inactive menu items."
356 (let ((inhibit-read-only t)
357 (inactive-string
358 (concat " " (make-string (length tmm-mid-prompt) ?\-)))
359 next)
360 (save-excursion
361 (goto-char (point-min))
362 (while (not (eobp))
363 (setq next (next-single-char-property-change (point) 'mouse-face))
364 (when (looking-at inactive-string)
365 (remove-text-properties (point) next '(mouse-face))
e43cbeae Juri Linkov2005-06-06 16:28:26 +0000366 (add-text-properties (point) next '(face tmm-inactive)))
04a5d30f
NR
Nick Roberts2005-06-03 11:24:06 +0000367 (goto-char next)))
368 (set-buffer-modified-p nil)))
369
20062d6b Richard M. Stallman1995-03-11 03:57:25 +0000370(defun tmm-add-prompt ()
04a5d30f
NR
Nick Roberts2005-06-03 11:24:06 +0000371 (unless tmm-c-prompt
372 (error "No active menu entries"))
362b9d48 Glenn Morris2011-01-15 12:03:38 -0800373 (setq tmm-old-mb-map (tmm-define-keys t))
7287f2f3
SM
Stefan Monnier2012-06-07 12:35:00 -0400374 (or tmm-completion-prompt
375 (add-hook 'completion-setup-hook
376 'tmm-completion-delete-prompt 'append))
377 (unwind-protect
378 (minibuffer-completion-help)
379 (remove-hook 'completion-setup-hook 'tmm-completion-delete-prompt))
380 (with-current-buffer "*Completions*"
362b9d48
GM
Glenn Morris2011-01-15 12:03:38 -0800381 (tmm-remove-inactive-mouse-face)
382 (when tmm-completion-prompt
47f730e3
MR
Martin Rudalics2014-12-18 18:12:24 +0100383 (let ((inhibit-read-only t)
384 (window (get-buffer-window "*Completions*")))
7287f2f3 Stefan Monnier2012-06-07 12:35:00 -0400385 (goto-char (point-min))
47f730e3
MR
Martin Rudalics2014-12-18 18:12:24 +0100386 (insert tmm-completion-prompt)
387 (when window
388 ;; Try to show everything just inserted and preserve height of
389 ;; *Completions* window. This should fix a behavior described
390 ;; in Bug#1291.
391 (fit-window-to-buffer window nil nil nil nil t)))))
362b9d48 Glenn Morris2011-01-15 12:03:38 -0800392 (insert tmm-c-prompt))
20062d6b Richard M. Stallman1995-03-11 03:57:25 +0000393
20062d6b Richard M. Stallman1995-03-11 03:57:25 +0000394(defun tmm-shortcut ()
fc225f66 Richard M. Stallman1995-10-30 16:33:49 +0000395 "Choose the shortcut that the user typed."
20062d6b Richard M. Stallman1995-03-11 03:57:25 +0000396 (interactive)
8989a920 Glenn Morris2009-01-09 04:44:15 +0000397 (let ((c last-command-event) s)
670ce6ea
RS
Richard M. Stallman1996-09-01 19:47:48 +0000398 (if (symbolp tmm-shortcut-style)
399 (setq c (funcall tmm-shortcut-style c)))
400 (if (memq c tmm-short-cuts)
fc225f66
RS
Richard M. Stallman1995-10-30 16:33:49 +0000401 (if (equal (buffer-name) "*Completions*")
402 (progn
b74f6606 Richard M. Stallman2005-05-21 04:50:59 +0000403 (goto-char (point-min))
fc225f66 Richard M. Stallman1995-10-30 16:33:49 +0000404 (re-search-forward
670ce6ea Richard M. Stallman1996-09-01 19:47:48 +0000405 (concat "\\(^\\|[ \t]\\)" (char-to-string c) tmm-mid-prompt))
fc225f66 Richard M. Stallman1995-10-30 16:33:49 +0000406 (choose-completion))
c2a8d4a7
GM
Gerd Moellmann2000-01-11 22:04:24 +0000407 ;; In minibuffer
408 (delete-region (minibuffer-prompt-end) (point-max))
a2754b6c
SM
Stefan Monnier2012-04-10 16:12:07 -0400409 (dolist (elt tmm-km-list)
410 (if (string=
411 (substring (car elt) 0
412 (min (1+ (length tmm-mid-prompt))
413 (length (car elt))))
414 (concat (char-to-string c) tmm-mid-prompt))
415 (setq s (car elt))))
fc225f66
RS
Richard M. Stallman1995-10-30 16:33:49 +0000416 (insert s)
417 (exit-minibuffer)))))
20062d6b
RS
Richard M. Stallman1995-03-11 03:57:25 +0000418
419(defun tmm-goto-completions ()
3ae704f4 Stefan Monnier2011-11-15 21:26:00 -0500420 "Jump to the completions buffer."
20062d6b Richard M. Stallman1995-03-11 03:57:25 +0000421 (interactive)
fbe91bbd
GM
Gerd Moellmann2000-01-17 15:32:56 +0000422 (let ((prompt-end (minibuffer-prompt-end)))
423 (setq tmm-c-prompt (buffer-substring prompt-end (point-max)))
3ae704f4 Stefan Monnier2011-11-15 21:26:00 -0500424 ;; FIXME: Why?
fbe91bbd Gerd Moellmann2000-01-17 15:32:56 +0000425 (delete-region prompt-end (point-max)))
fc225f66 Richard M. Stallman1995-10-30 16:33:49 +0000426 (switch-to-buffer-other-window "*Completions*")
20062d6b
RS
Richard M. Stallman1995-03-11 03:57:25 +0000427 (search-forward tmm-c-prompt)
428 (search-backward tmm-c-prompt))
429
97895167 Pavel Janík2002-01-27 11:17:06 +0000430(defun tmm-get-keymap (elt &optional in-x-menu)
3ae704f4 Stefan Monnier2011-11-15 21:26:00 -0500431 "Prepend (DOCSTRING EVENT BINDING) to free variable `tmm-km-list'.
20062d6b Richard M. Stallman1995-03-11 03:57:25 +0000432The values are deduced from the argument ELT, that should be an
fc225f66 Richard M. Stallman1995-10-30 16:33:49 +0000433element of keymap, an `x-popup-menu' argument, or an element of
20062d6b Richard M. Stallman1995-03-11 03:57:25 +0000434`x-popup-menu' argument (when IN-X-MENU is not-nil).
77cc5db0
RS
Richard M. Stallman1996-01-02 05:59:20 +0000435This function adds the element only if it is not already present.
436It uses the free variable `tmm-table-undef' to keep undefined keys."
dc9ed794 Stefan Monnier2010-05-11 16:07:12 -0400437 (let (km str plist filter visible enable (event (car elt)))
20062d6b
RS
Richard M. Stallman1995-03-11 03:57:25 +0000438 (setq elt (cdr elt))
439 (if (eq elt 'undefined)
440 (setq tmm-table-undef (cons (cons event nil) tmm-table-undef))
42d140b4
KH
Karl Heuer1998-04-13 18:55:05 +0000441 (unless (assoc event tmm-table-undef)
442 (cond ((if (listp elt)
443 (or (keymapp elt) (eq (car elt) 'lambda))
dc9ed794 Stefan Monnier2010-05-11 16:07:12 -0400444 (and (symbolp elt) (fboundp elt)))
42d140b4 Karl Heuer1998-04-13 18:55:05 +0000445 (setq km elt))
0595722b Gerd Moellmann2001-05-18 13:10:43 +0000446
42d140b4
KH
Karl Heuer1998-04-13 18:55:05 +0000447 ((if (listp (cdr-safe elt))
448 (or (keymapp (cdr-safe elt))
449 (eq (car (cdr-safe elt)) 'lambda))
dc9ed794 Stefan Monnier2010-05-11 16:07:12 -0400450 (and (symbolp (cdr-safe elt)) (fboundp (cdr-safe elt))))
42d140b4
KH
Karl Heuer1998-04-13 18:55:05 +0000451 (setq km (cdr elt))
452 (and (stringp (car elt)) (setq str (car elt))))
0595722b Gerd Moellmann2001-05-18 13:10:43 +0000453
42d140b4
KH
Karl Heuer1998-04-13 18:55:05 +0000454 ((if (listp (cdr-safe (cdr-safe elt)))
455 (or (keymapp (cdr-safe (cdr-safe elt)))
456 (eq (car (cdr-safe (cdr-safe elt))) 'lambda))
dc9ed794 Stefan Monnier2010-05-11 16:07:12 -0400457 (and (symbolp (cdr-safe (cdr-safe elt)))
70edffb1 Stefan Monnier2012-10-28 10:56:51 -0400458 (fboundp (cdr-safe (cdr-safe elt)))))
e9bed1ef Chong Yidong2008-10-29 20:57:03 +0000459 (setq km (cddr elt))
dc9ed794 Stefan Monnier2010-05-11 16:07:12 -0400460 (and (stringp (car elt)) (setq str (car elt))))
0595722b Gerd Moellmann2001-05-18 13:10:43 +0000461
42d140b4 Karl Heuer1998-04-13 18:55:05 +0000462 ((eq (car-safe elt) 'menu-item)
0595722b Gerd Moellmann2001-05-18 13:10:43 +0000463 ;; (menu-item TITLE COMMAND KEY ...)
dd81ca0d Richard M. Stallman1998-06-14 18:46:20 +0000464 (setq plist (cdr-safe (cdr-safe (cdr-safe elt))))
0595722b
GM
Gerd Moellmann2001-05-18 13:10:43 +0000465 (when (consp (car-safe plist))
466 (setq plist (cdr-safe plist)))
42d140b4 Karl Heuer1998-04-13 18:55:05 +0000467 (setq km (nth 2 elt))
c19cc275 Stefan Monnier2000-12-02 21:31:12 +0000468 (setq str (eval (nth 1 elt)))
dd81ca0d
RS
Richard M. Stallman1998-06-14 18:46:20 +0000469 (setq filter (plist-get plist :filter))
470 (if filter
471 (setq km (funcall filter km)))
97895167
PJ
Pavel Janík2002-01-27 11:17:06 +0000472 (setq visible (plist-get plist :visible))
473 (if visible
474 (setq km (and (eval visible) km)))
7ae862e2
NR
Nick Roberts2005-05-13 23:23:42 +0000475 (setq enable (plist-get plist :enable))
476 (if enable
dc9ed794 Stefan Monnier2010-05-11 16:07:12 -0400477 (setq km (if (eval enable) km 'ignore))))
0595722b Gerd Moellmann2001-05-18 13:10:43 +0000478
42d140b4
KH
Karl Heuer1998-04-13 18:55:05 +0000479 ((if (listp (cdr-safe (cdr-safe (cdr-safe elt))))
480 (or (keymapp (cdr-safe (cdr-safe (cdr-safe elt))))
481 (eq (car (cdr-safe (cdr-safe (cdr-safe elt)))) 'lambda))
dc9ed794
SM
Stefan Monnier2010-05-11 16:07:12 -0400482 (and (symbolp (cdr-safe (cdr-safe (cdr-safe elt))))
483 (fboundp (cdr-safe (cdr-safe (cdr-safe elt))))))
70edffb1 Stefan Monnier2012-10-28 10:56:51 -0400484 ; New style of easy-menu
e9bed1ef Chong Yidong2008-10-29 20:57:03 +0000485 (setq km (cdr (cddr elt)))
dc9ed794 Stefan Monnier2010-05-11 16:07:12 -0400486 (and (stringp (car elt)) (setq str (car elt))))
0595722b Gerd Moellmann2001-05-18 13:10:43 +0000487
42d140b4 Karl Heuer1998-04-13 18:55:05 +0000488 ((stringp event) ; x-popup or x-popup element
70edffb1
SM
Stefan Monnier2012-10-28 10:56:51 -0400489 (setq str event)
490 (setq event nil)
491 (setq km (if (or in-x-menu (stringp (car-safe elt)))
492 elt (cons 'keymap elt)))))
362b9d48 Glenn Morris2011-01-15 12:03:38 -0800493 (unless (or (eq km 'ignore) (null str))
dc9ed794
SM
Stefan Monnier2010-05-11 16:07:12 -0400494 (let ((binding (where-is-internal km nil t)))
495 (when binding
496 (setq binding (key-description binding))
497 ;; Try to align the keybindings.
498 (let ((colwidth (min 30 (- (/ (window-width) 2) 10))))
499 (setq str
500 (concat str
501 (make-string (max 2 (- colwidth
502 (string-width str)
503 (string-width binding)))
504 ?\s)
505 binding)))))))
20062d6b Richard M. Stallman1995-03-11 03:57:25 +0000506 (and km (stringp km) (setq str km))
2a9f2437
RS
Richard M. Stallman1997-08-24 04:00:25 +0000507 ;; Verify that the command is enabled;
508 ;; if not, don't mention it.
509 (when (and km (symbolp km) (get km 'menu-enable))
04a5d30f Nick Roberts2005-06-03 11:24:06 +0000510 (setq km (if (eval (get km 'menu-enable)) km 'ignore)))
20062d6b
RS
Richard M. Stallman1995-03-11 03:57:25 +0000511 (and km str
512 (or (assoc str tmm-km-list)
c19cc275 Stefan Monnier2000-12-02 21:31:12 +0000513 (push (cons str (cons event km)) tmm-km-list))))))
20062d6b Richard M. Stallman1995-03-11 03:57:25 +0000514
20062d6b Richard M. Stallman1995-03-11 03:57:25 +0000515(defun tmm-get-keybind (keyseq)
fc225f66 Richard M. Stallman1995-10-30 16:33:49 +0000516 "Return the current binding of KEYSEQ, merging prefix definitions.
91a5e367 Karl Heuer1996-01-04 23:50:50 +0000517If KEYSEQ is a prefix key that has local and global bindings,
fc225f66
RS
Richard M. Stallman1995-10-30 16:33:49 +0000518we merge them into a single keymap which shows the proper order of the menu.
519However, for the menu bar itself, the value does not take account
520of `menu-bar-final-items'."
4d0463b9 Stefan Monnier2013-02-13 08:40:00 -0500521 (lookup-key (cons 'keymap (nreverse (current-active-maps))) keyseq))
20062d6b Richard M. Stallman1995-03-11 03:57:25 +0000522
20062d6b
RS
Richard M. Stallman1995-03-11 03:57:25 +0000523(provide 'tmm)
524
20062d6b Richard M. Stallman1995-03-11 03:57:25 +0000525;;; tmm.el ends here