Commit | Line | Data |
---|---|---|
be010748 | 1 | ;;; tmm.el --- text mode access to menu-bar |
20062d6b RS |
2 | |
3 | ;; Copyright (C) 1994, 1995 Free Software Foundation, Inc. | |
4 | ||
5 | ;; Author: Ilya Zakharevich <ilya@math.mps.ohio-state.edu> | |
fc225f66 | 6 | ;; Maintainer: FSF |
20062d6b | 7 | |
d440e474 | 8 | ;; This file is part of GNU Emacs. |
20062d6b RS |
9 | |
10 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
11 | ;; it under the terms of the GNU General Public License as published by | |
12 | ;; the Free Software Foundation; either version 2, or (at your option) | |
13 | ;; any later version. | |
14 | ||
15 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;; GNU General Public License for more details. | |
19 | ||
20 | ;; You should have received a copy of the GNU General Public License | |
21 | ;; along with GNU Emacs; see the file COPYING. If not, write to | |
22 | ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
23 | ||
24 | ;;; Commentary ============================================================ | |
25 | ||
26 | ;;; To use this package add | |
27 | ||
28 | ;;; (autoload 'tmm-menubar 'tmm "Text mode substitute for menubar" t) | |
29 | ;;; (global-set-key [f10] 'tmm-menubar) | |
30 | ||
31 | ;;; to your .emacs file. You can also add your own access to different | |
32 | ;;; menus available in Window System Emacs modelling definition after | |
33 | ;;; tmm-menubar. | |
34 | ||
35 | (require 'electric) | |
20062d6b RS |
36 | |
37 | ;;; The following will be localized, added only to pacify the compiler. | |
38 | (defvar tmm-short-cuts) | |
fc225f66 | 39 | (defvar tmm-old-mb-map nil) |
20062d6b RS |
40 | (defvar tmm-old-comp-map) |
41 | (defvar tmm-c-prompt) | |
42 | (defvar tmm-km-list) | |
43 | (defvar tmm-table-undef) | |
44 | ||
e6a5c7de | 45 | ;;;###autoload (define-key global-map "\M-`" 'tmm-menubar) |
b46324e6 | 46 | ;;;###autoload (define-key global-map [f10] 'tmm-menubar) |
77cc5db0 | 47 | ;;;###autoload (define-key global-map [menu-bar mouse-1] 'tmm-menubar-mouse) |
afb1835e | 48 | |
20062d6b | 49 | ;;;###autoload |
77cc5db0 | 50 | (defun tmm-menubar (&optional x-position) |
20062d6b | 51 | "Text-mode emulation of looking and choosing from a menubar. |
77cc5db0 RS |
52 | See the documentation for `tmm-prompt'. |
53 | X-POSITION, if non-nil, specifies a horizontal position within the menu bar; | |
54 | we make that menu bar item (the one at that position) the default choice." | |
20062d6b RS |
55 | (interactive) |
56 | (run-hooks 'menu-bar-update-hook) | |
fc225f66 | 57 | ;; Obey menu-bar-final-items; put those items last. |
77cc5db0 RS |
58 | (let ((menu-bar (tmm-get-keybind [menu-bar])) |
59 | menu-bar-item) | |
fc225f66 RS |
60 | (let ((list menu-bar-final-items)) |
61 | (while list | |
62 | (let ((item (car list))) | |
63 | ;; ITEM is the name of an item that we want to put last. | |
64 | ;; Find it in MENU-BAR and move it to the end. | |
65 | (let ((this-one (assq item menu-bar))) | |
66 | (setq menu-bar (append (delq this-one menu-bar) | |
67 | (list this-one))))) | |
68 | (setq list (cdr list)))) | |
77cc5db0 RS |
69 | (if x-position |
70 | (let ((tail menu-bar) | |
71 | this-one | |
72 | (column 0)) | |
73 | (while (and tail (< column x-position)) | |
74 | (setq this-one (car tail)) | |
75 | (if (and (consp (car tail)) | |
76 | (consp (cdr (car tail))) | |
77 | (stringp (nth 1 (car tail)))) | |
78 | (setq column (+ column | |
79 | (length (nth 1 (car tail))) | |
80 | 1))) | |
81 | (setq tail (cdr tail))) | |
82 | (setq menu-bar-item (car this-one)))) | |
83 | (tmm-prompt menu-bar nil menu-bar-item))) | |
84 | ||
85 | (defun tmm-menubar-mouse (event) | |
86 | "Text-mode emulation of looking and choosing from a menubar. | |
87 | This command is used when you click the mouse in the menubar | |
88 | on a console which has no window system but does have a mouse. | |
89 | See the documentation for `tmm-prompt'." | |
90 | (interactive "e") | |
91 | (tmm-menubar (car (posn-x-y (event-start event))))) | |
20062d6b RS |
92 | |
93 | (defvar tmm-mid-prompt "==>" | |
94 | "String to insert between shortcut and menu item or nil.") | |
95 | ||
96 | (defvar tmm-mb-map nil | |
97 | "A place to store minibuffer map.") | |
98 | ||
99 | (defvar tmm-completion-prompt | |
100 | "Press PageUp Key to reach this buffer from the minibuffer. | |
101 | Alternatively, you can use Up/Down keys (or your History keys) to change | |
102 | the item in the minibuffer, and press RET when you are done, or press the | |
10fe2d38 | 103 | marked letters to pick up your choice. Type C-g or ESC ESC ESC to cancel. |
20062d6b RS |
104 | " |
105 | "What insert on top of completion buffer.") | |
106 | ||
107 | ;;;###autoload | |
77cc5db0 | 108 | (defun tmm-prompt (bind &optional in-popup default-item) |
20062d6b | 109 | "Text-mode emulation of calling the bindings in keymap. |
77cc5db0 RS |
110 | Creates a text-mode menu of possible choices. You can access the elements |
111 | in the menu in two ways: | |
112 | *) via history mechanism from minibuffer; | |
20062d6b RS |
113 | *) Or via completion-buffer that is automatically shown. |
114 | The last alternative is currently a hack, you cannot use mouse reliably. | |
77cc5db0 RS |
115 | If the optional argument IN-POPUP is non-nil, it should compatible with |
116 | `x-popup-menu', otherwise the argument BIND should be keymap." | |
20062d6b | 117 | (if in-popup (if bind (setq bind in-popup) (x-popup-menu nil in-popup))) |
fc225f66 | 118 | (let (gl-str tmm-km-list out history history-len tmm-table-undef tmm-c-prompt |
20062d6b RS |
119 | tmm-old-mb-map tmm-old-comp-map tmm-short-cuts) |
120 | (run-hooks 'activate-menubar-hook) | |
121 | (mapcar (function (lambda (elt) | |
122 | (if (stringp elt) | |
123 | (setq gl-str elt) | |
fc225f66 RS |
124 | (and (listp elt) (tmm-get-keymap elt in-popup))))) |
125 | bind) | |
77cc5db0 | 126 | (setq foo default-item foo1 bind) |
20062d6b | 127 | (and tmm-km-list |
77cc5db0 | 128 | (let ((index-of-default 0)) |
fc225f66 RS |
129 | (if tmm-mid-prompt |
130 | (setq tmm-km-list (tmm-add-shortcuts tmm-km-list)) | |
131 | t) | |
77cc5db0 RS |
132 | ;; Find the default item's index within the menu bar. |
133 | ;; We use this to decide the initial minibuffer contents | |
134 | ;; and initial history position. | |
135 | (if default-item | |
136 | (let ((tail bind)) | |
137 | (while (and tail | |
138 | (not (eq (car-safe (car tail)) default-item))) | |
139 | ;; Be careful to count only the elements of BIND | |
140 | ;; that actually constitute menu bar items. | |
141 | (if (and (consp (car tail)) | |
142 | (stringp (car-safe (cdr (car tail))))) | |
143 | (setq index-of-default (1+ index-of-default))) | |
144 | (setq tail (cdr tail))))) | |
fc225f66 RS |
145 | (setq history (reverse (mapcar 'car tmm-km-list))) |
146 | (setq history-len (length history)) | |
147 | (setq history (append history history history history)) | |
77cc5db0 | 148 | (setq tmm-c-prompt (nth (- history-len 1 index-of-default) history)) |
fc225f66 RS |
149 | (add-hook 'minibuffer-setup-hook 'tmm-add-prompt) |
150 | (unwind-protect | |
151 | (setq out | |
152 | (completing-read | |
153 | (concat gl-str " (up/down to change, PgUp to menu): ") | |
154 | tmm-km-list nil t nil | |
77cc5db0 | 155 | (cons 'history (- (* 2 history-len) index-of-default)))) |
fc225f66 | 156 | (save-excursion |
c5c4b51c RS |
157 | (remove-hook 'minibuffer-setup-hook 'tmm-add-prompt) |
158 | (if (get-buffer "*Completions*") | |
159 | (progn | |
160 | (set-buffer "*Completions*") | |
161 | (use-local-map tmm-old-comp-map) | |
162 | (bury-buffer (current-buffer))))) | |
fc225f66 | 163 | ))) |
20062d6b RS |
164 | (setq bind (cdr (assoc out tmm-km-list))) |
165 | (and (null bind) | |
166 | (> (length out) (length tmm-c-prompt)) | |
167 | (string= (substring out 0 (length tmm-c-prompt)) tmm-c-prompt) | |
168 | (setq out (substring out (length tmm-c-prompt)) | |
169 | bind (cdr (assoc out tmm-km-list)))) | |
fc225f66 RS |
170 | (and (null bind) |
171 | (setq out (try-completion out tmm-km-list) | |
172 | bind (cdr (assoc out tmm-km-list)))) | |
20062d6b RS |
173 | (setq last-command-event (car bind)) |
174 | (setq bind (cdr bind)) | |
175 | (if bind | |
176 | (if in-popup (tmm-prompt t bind) | |
177 | (if (keymapp bind) | |
178 | (if (listp bind) | |
179 | (progn | |
180 | (condition-case nil | |
181 | (require 'mouse) | |
182 | (error nil)) | |
183 | (condition-case nil | |
184 | (x-popup-menu nil bind) ; Get the shortcuts | |
185 | (error nil)) | |
186 | (tmm-prompt bind)) | |
187 | (tmm-prompt (symbol-value bind)) | |
188 | ) | |
189 | (if last-command-event | |
190 | (call-interactively bind) | |
191 | bind))) | |
192 | gl-str))) | |
193 | ||
20062d6b RS |
194 | |
195 | (defun tmm-add-shortcuts (list) | |
196 | "Adds shortcuts to cars of elements of the list. | |
197 | Takes a list of lists with a string as car, returns list with | |
fc225f66 RS |
198 | shortcuts added to these cars. |
199 | Stores a list of all the shortcuts in the free variable `tmm-short-cuts'." | |
200 | (let ((next-shortcut-number 0)) | |
201 | (mapcar (lambda (elt) | |
202 | (let ((str (car elt)) f b) | |
203 | (setq f (upcase (substring str 0 1))) | |
204 | ;; If does not work, try beginning of the other word | |
205 | (if (and (member f tmm-short-cuts) | |
206 | (string-match " \\([^ ]\\)" str)) | |
207 | (setq f (upcase (substring | |
208 | str | |
209 | (setq b (match-beginning 1)) (1+ b))))) | |
210 | ;; If we don't have an unique letter shortcut, | |
211 | ;; pick a digit as a shortcut instead. | |
212 | (if (member f tmm-short-cuts) | |
213 | (if (< next-shortcut-number 10) | |
214 | (setq f (format "%d" next-shortcut-number) | |
215 | next-shortcut-number (1+ next-shortcut-number)) | |
216 | (setq f nil))) | |
217 | (if (null f) | |
218 | elt | |
219 | (setq tmm-short-cuts (cons f tmm-short-cuts)) | |
220 | (cons (concat f tmm-mid-prompt str) (cdr elt))))) | |
221 | (reverse list)))) | |
20062d6b | 222 | |
b46324e6 RS |
223 | (defun tmm-define-keys () |
224 | (mapcar (lambda (str) | |
225 | (define-key (current-local-map) str 'tmm-shortcut) | |
226 | (define-key (current-local-map) (downcase str) 'tmm-shortcut)) | |
227 | tmm-short-cuts) | |
228 | (define-key (current-local-map) [pageup] 'tmm-goto-completions) | |
229 | (define-key (current-local-map) [prior] 'tmm-goto-completions) | |
230 | (define-key (current-local-map) "\ev" 'tmm-goto-completions) | |
b46324e6 RS |
231 | (define-key (current-local-map) "\C-n" 'next-history-element) |
232 | (define-key (current-local-map) "\C-p" 'previous-history-element)) | |
233 | ||
20062d6b RS |
234 | (defun tmm-add-prompt () |
235 | (remove-hook 'minibuffer-setup-hook 'tmm-add-prompt) | |
afb1835e RS |
236 | (make-local-hook 'minibuffer-exit-hook) |
237 | (add-hook 'minibuffer-exit-hook 'tmm-delete-map nil t) | |
b46324e6 | 238 | (let ((win (selected-window))) |
20062d6b | 239 | (setq tmm-old-mb-map (current-local-map)) |
b46324e6 RS |
240 | (use-local-map (append (make-sparse-keymap) tmm-old-mb-map)) |
241 | (tmm-define-keys) | |
20062d6b RS |
242 | ;; Get window and hide it for electric mode to get correct size |
243 | (save-window-excursion | |
fc225f66 RS |
244 | (let ((completions |
245 | (mapcar 'car minibuffer-completion-table))) | |
246 | (with-output-to-temp-buffer "*Completions*" | |
247 | (display-completion-list completions))) | |
20062d6b RS |
248 | (set-buffer "*Completions*") |
249 | (goto-char 1) | |
250 | (insert tmm-completion-prompt) | |
251 | ) | |
252 | (save-excursion | |
253 | (other-window 1) ; Electric-pop-up-window does | |
254 | ; not work in minibuffer | |
255 | (set-buffer (window-buffer (Electric-pop-up-window "*Completions*"))) | |
256 | (setq tmm-old-comp-map (current-local-map)) | |
b46324e6 RS |
257 | (use-local-map (append (make-sparse-keymap) tmm-old-comp-map)) |
258 | (tmm-define-keys) | |
20062d6b RS |
259 | (select-window win) ; Cannot use |
260 | ; save-window-excursion, since | |
261 | ; it restores the size | |
262 | ) | |
263 | (insert tmm-c-prompt))) | |
264 | ||
265 | (defun tmm-delete-map () | |
afb1835e | 266 | (remove-hook 'minibuffer-exit-hook 'tmm-delete-map t) |
fc225f66 RS |
267 | (if tmm-old-mb-map |
268 | (use-local-map tmm-old-mb-map))) | |
20062d6b RS |
269 | |
270 | (defun tmm-shortcut () | |
fc225f66 | 271 | "Choose the shortcut that the user typed." |
20062d6b RS |
272 | (interactive) |
273 | (let ((c (upcase (char-to-string last-command-char))) s) | |
274 | (if (member c tmm-short-cuts) | |
fc225f66 RS |
275 | (if (equal (buffer-name) "*Completions*") |
276 | (progn | |
277 | (beginning-of-buffer) | |
278 | (re-search-forward | |
279 | (concat "\\(^\\|[ \t]\\)" c tmm-mid-prompt)) | |
280 | (choose-completion)) | |
281 | (erase-buffer) ; In minibuffer | |
282 | (mapcar (lambda (elt) | |
283 | (if (string= | |
284 | (substring (car elt) 0 | |
285 | (min (1+ (length tmm-mid-prompt)) | |
286 | (length (car elt)))) | |
287 | (concat c tmm-mid-prompt)) | |
288 | (setq s (car elt)))) | |
289 | tmm-km-list) | |
290 | (insert s) | |
291 | (exit-minibuffer))))) | |
20062d6b RS |
292 | |
293 | (defun tmm-goto-completions () | |
294 | (interactive) | |
295 | (setq tmm-c-prompt (buffer-string)) | |
296 | (erase-buffer) | |
fc225f66 | 297 | (switch-to-buffer-other-window "*Completions*") |
20062d6b RS |
298 | (search-forward tmm-c-prompt) |
299 | (search-backward tmm-c-prompt)) | |
300 | ||
301 | ||
302 | (defun tmm-get-keymap (elt &optional in-x-menu) | |
303 | "Prepends (DOCSTRING EVENT BINDING) to free variable `tmm-km-list'. | |
304 | The values are deduced from the argument ELT, that should be an | |
fc225f66 | 305 | element of keymap, an `x-popup-menu' argument, or an element of |
20062d6b | 306 | `x-popup-menu' argument (when IN-X-MENU is not-nil). |
77cc5db0 RS |
307 | This function adds the element only if it is not already present. |
308 | It uses the free variable `tmm-table-undef' to keep undefined keys." | |
20062d6b RS |
309 | (let (km str cache (event (car elt))) |
310 | (setq elt (cdr elt)) | |
311 | (if (eq elt 'undefined) | |
312 | (setq tmm-table-undef (cons (cons event nil) tmm-table-undef)) | |
313 | (or | |
314 | (assoc event tmm-table-undef) | |
315 | (and (if (listp elt) | |
316 | (keymapp elt) | |
317 | (fboundp elt)) | |
318 | (setq km elt)) | |
319 | (and (if (listp (cdr-safe elt)) | |
320 | (keymapp (cdr-safe elt)) | |
321 | (fboundp (cdr-safe elt))) | |
322 | (setq km (cdr elt)) | |
323 | (and (stringp (car elt)) (setq str (car elt)))) | |
324 | (and (if (listp (cdr-safe (cdr-safe elt))) | |
325 | (keymapp (cdr-safe (cdr-safe elt))) | |
326 | (fboundp (cdr-safe (cdr-safe elt)))) | |
327 | (setq km (cdr (cdr elt))) | |
328 | (and (stringp (car elt)) (setq str (car elt))) | |
329 | (or (and str | |
330 | (stringp (cdr (car (cdr elt)))) ; keyseq cache | |
331 | (setq cache (cdr (car (cdr elt)))) | |
332 | cache (setq str (concat str cache))) str)) | |
333 | (and (if (listp (cdr-safe (cdr-safe (cdr-safe elt)))) | |
334 | (keymapp (cdr-safe (cdr-safe (cdr-safe elt)))) | |
335 | (fboundp (cdr-safe (cdr-safe (cdr-safe elt))))) | |
336 | ; New style of easy-menu | |
337 | (setq km (cdr (cdr (cdr elt)))) | |
338 | (and (stringp (car elt)) (setq str (car elt))) | |
339 | (or (and str | |
340 | (stringp (cdr (car (cdr (cdr elt))))) ; keyseq cache | |
341 | (setq cache (cdr (car (cdr (cdr elt))))) | |
342 | cache (setq str (concat str cache))) | |
343 | str)) | |
344 | (and (stringp event) ; x-popup or x-popup element | |
345 | (if (or in-x-menu (stringp (car-safe elt))) | |
346 | (setq str event event nil km elt) | |
347 | (setq str event event nil km (cons 'keymap elt)) | |
348 | ))) | |
349 | (and km (stringp km) (setq str km)) | |
350 | (and km str | |
351 | (or (assoc str tmm-km-list) | |
352 | (setq tmm-km-list | |
353 | (cons (cons str (cons event km)) tmm-km-list))) | |
354 | )))) | |
355 | ||
356 | ||
357 | (defun tmm-get-keybind (keyseq) | |
fc225f66 RS |
358 | "Return the current binding of KEYSEQ, merging prefix definitions. |
359 | If KEYSEQ is a prefix key that has local and gloibal bindings, | |
360 | we merge them into a single keymap which shows the proper order of the menu. | |
361 | However, for the menu bar itself, the value does not take account | |
362 | of `menu-bar-final-items'." | |
20062d6b | 363 | (let (allbind bind) |
fc225f66 RS |
364 | (setq bind (key-binding keyseq)) |
365 | ;; If KEYSEQ is a prefix key, then BIND is either nil | |
366 | ;; or a symbol defined as a keymap (which satisfies keymapp). | |
367 | (if (keymapp bind) | |
368 | (setq bind nil)) | |
369 | ;; If we have a non-keymap definition, return that. | |
370 | (or bind | |
371 | (progn | |
372 | ;; Otherwise, it is a prefix, so make a list of the subcommands. | |
373 | ;; Make a list of all the bindings in all the keymaps. | |
374 | (setq allbind (mapcar 'cdr (minor-mode-key-binding keyseq))) | |
375 | (setq allbind (cons (local-key-binding keyseq) allbind)) | |
376 | (setq allbind (cons (global-key-binding keyseq) allbind)) | |
377 | ;; Merge all the elements of ALLBIND into one keymap. | |
378 | (mapcar (lambda (in) | |
379 | (if (and (symbolp in) (keymapp in)) | |
380 | (setq in (symbol-function in))) | |
381 | (and in (keymapp in) | |
382 | (if (keymapp bind) | |
383 | (setq bind (nconc bind (copy-sequence (cdr in)))) | |
384 | (setq bind (copy-sequence in))))) | |
385 | allbind) | |
386 | ;; Return that keymap. | |
387 | bind)))) | |
20062d6b RS |
388 | |
389 | (add-hook 'calendar-load-hook (lambda () (require 'cal-menu))) | |
390 | ||
391 | ||
392 | (provide 'tmm) | |
393 | ||
394 | ||
395 | ;;; tmm.el ends here |