Commit | Line | Data |
---|---|---|
20062d6b RS |
1 | ;;; tmm.el - text mode access to menu-bar |
2 | ||
3 | ;; Copyright (C) 1994, 1995 Free Software Foundation, Inc. | |
4 | ||
5 | ;; Author: Ilya Zakharevich <ilya@math.mps.ohio-state.edu> | |
6 | ||
d440e474 | 7 | ;; This file is part of GNU Emacs. |
20062d6b RS |
8 | |
9 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
10 | ;; it under the terms of the GNU General Public License as published by | |
11 | ;; the Free Software Foundation; either version 2, or (at your option) | |
12 | ;; any later version. | |
13 | ||
14 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | ;; GNU General Public License for more details. | |
18 | ||
19 | ;; You should have received a copy of the GNU General Public License | |
20 | ;; along with GNU Emacs; see the file COPYING. If not, write to | |
21 | ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
22 | ||
23 | ;;; Commentary ============================================================ | |
24 | ||
25 | ;;; To use this package add | |
26 | ||
27 | ;;; (autoload 'tmm-menubar 'tmm "Text mode substitute for menubar" t) | |
28 | ;;; (global-set-key [f10] 'tmm-menubar) | |
29 | ||
30 | ;;; to your .emacs file. You can also add your own access to different | |
31 | ;;; menus available in Window System Emacs modelling definition after | |
32 | ;;; tmm-menubar. | |
33 | ||
34 | (require 'electric) | |
35 | (define-key completion-list-mode-map "\e\e" 'abort-recursive-edit) | |
36 | (define-key completion-list-mode-map [left] 'backward-word) | |
37 | (define-key completion-list-mode-map [right] 'forward-word) | |
38 | ;(define-key minibuffer-local-must-match-map [pageup] 'tmm-goto-completions) | |
39 | ;(define-key minibuffer-local-must-match-map [prior] 'tmm-goto-completions) | |
40 | ;(define-key minibuffer-local-must-match-map "\ev" 'tmm-goto-completions) | |
41 | (define-key minibuffer-local-must-match-map [up] 'previous-history-element) | |
42 | (define-key minibuffer-local-must-match-map [down] 'next-history-element) | |
43 | ||
44 | ;;; The following will be localized, added only to pacify the compiler. | |
45 | (defvar tmm-short-cuts) | |
46 | (defvar tmm-old-mb-map) | |
47 | (defvar tmm-old-comp-map) | |
48 | (defvar tmm-c-prompt) | |
49 | (defvar tmm-km-list) | |
50 | (defvar tmm-table-undef) | |
51 | ||
52 | ;;;###autoload | |
53 | (defun tmm-menubar () | |
54 | "Text-mode emulation of looking and choosing from a menubar. | |
55 | See the documentation for `tmm-prompt'." | |
56 | (interactive) | |
57 | (run-hooks 'menu-bar-update-hook) | |
58 | (tmm-prompt (tmm-get-keybind [menu-bar]))) | |
59 | ||
60 | (defvar tmm-mid-prompt "==>" | |
61 | "String to insert between shortcut and menu item or nil.") | |
62 | ||
63 | (defvar tmm-mb-map nil | |
64 | "A place to store minibuffer map.") | |
65 | ||
66 | (defvar tmm-completion-prompt | |
67 | "Press PageUp Key to reach this buffer from the minibuffer. | |
68 | Alternatively, you can use Up/Down keys (or your History keys) to change | |
69 | the item in the minibuffer, and press RET when you are done, or press the | |
70 | marked letters to pick up your choice. ESC ESC to cancel. | |
71 | " | |
72 | "What insert on top of completion buffer.") | |
73 | ||
74 | ;;;###autoload | |
75 | (defun tmm-prompt (bind &optional in-popup) | |
76 | "Text-mode emulation of calling the bindings in keymap. | |
77 | Creates a text-mode menu of possible choices. You can access the elements | |
78 | in the menu: | |
79 | *) Either via history mechanism from minibuffer; | |
80 | *) Or via completion-buffer that is automatically shown. | |
81 | The last alternative is currently a hack, you cannot use mouse reliably. | |
82 | If the optional argument IN-POPUP is set, is argument-compatible with | |
83 | `x-popup-menu', otherwise the argument BIND should be a cdr of sparse keymap." | |
84 | (if in-popup (if bind (setq bind in-popup) (x-popup-menu nil in-popup))) | |
85 | (let (gl-str tmm-km-list out compl-list compl-list-l tmm-table-undef tmm-c-prompt | |
86 | tmm-old-mb-map tmm-old-comp-map tmm-short-cuts) | |
87 | (run-hooks 'activate-menubar-hook) | |
88 | (mapcar (function (lambda (elt) | |
89 | (if (stringp elt) | |
90 | (setq gl-str elt) | |
91 | (and (listp elt) (tmm-get-keymap elt in-popup))) | |
92 | )) bind) | |
93 | (and tmm-km-list | |
94 | (if tmm-mid-prompt | |
95 | (setq tmm-km-list (reverse (tmm-add-shortcuts tmm-km-list))) | |
96 | t) | |
97 | (setq compl-list (mapcar 'car tmm-km-list)) | |
98 | (setq compl-list-l (length compl-list)) | |
99 | (setq compl-list (append compl-list compl-list compl-list compl-list)) | |
100 | (setq tmm-c-prompt (nth (1- compl-list-l) compl-list)) | |
101 | (add-hook 'minibuffer-setup-hook 'tmm-add-prompt) | |
102 | (unwind-protect | |
103 | (setq out | |
104 | (completing-read | |
105 | (concat gl-str " (up/down to change, PgUp to menu): ") | |
106 | tmm-km-list nil t nil | |
107 | (cons 'compl-list (* 2 compl-list-l)))) | |
108 | ;;(add-hook 'minibuffer-setup-hook 'tmm-remove-shortcuts) | |
109 | ;;(save-excursion | |
110 | ;; (set-buffer "*Completions*") | |
111 | ;; (use-local-map tmm-old-mb-map)) | |
112 | (save-excursion | |
113 | (set-buffer "*Completions*") | |
114 | (use-local-map tmm-old-comp-map) | |
115 | (bury-buffer (current-buffer))) | |
116 | )) | |
117 | (setq bind (cdr (assoc out tmm-km-list))) | |
118 | (and (null bind) | |
119 | (> (length out) (length tmm-c-prompt)) | |
120 | (string= (substring out 0 (length tmm-c-prompt)) tmm-c-prompt) | |
121 | (setq out (substring out (length tmm-c-prompt)) | |
122 | bind (cdr (assoc out tmm-km-list)))) | |
123 | (setq last-command-event (car bind)) | |
124 | (setq bind (cdr bind)) | |
125 | (if bind | |
126 | (if in-popup (tmm-prompt t bind) | |
127 | (if (keymapp bind) | |
128 | (if (listp bind) | |
129 | (progn | |
130 | (condition-case nil | |
131 | (require 'mouse) | |
132 | (error nil)) | |
133 | (condition-case nil | |
134 | (x-popup-menu nil bind) ; Get the shortcuts | |
135 | (error nil)) | |
136 | (tmm-prompt bind)) | |
137 | (tmm-prompt (symbol-value bind)) | |
138 | ) | |
139 | (if last-command-event | |
140 | (call-interactively bind) | |
141 | bind))) | |
142 | gl-str))) | |
143 | ||
144 | (defun tmm-remove-shortcuts () | |
145 | (use-local-map tmm-mb-map)) | |
146 | ||
147 | (defun tmm-add-shortcuts (list) | |
148 | "Adds shortcuts to cars of elements of the list. | |
149 | Takes a list of lists with a string as car, returns list with | |
150 | shortcuts added to these cars. Adds the shortcuts to a free variable | |
151 | `tmm-short-cuts'." | |
152 | (mapcar (lambda (elt) | |
153 | (let ((str (car elt)) f b) | |
154 | (setq f (upcase (substring str 0 1))) | |
155 | ;; If does not work, try beginning of the other word | |
156 | (if (and (member f tmm-short-cuts) | |
157 | (string-match " \\([^ ]\\)" str)) | |
158 | (setq f (upcase (substring | |
159 | str | |
160 | (setq b (match-beginning 1)) (1+ b))))) | |
161 | (if (member f tmm-short-cuts) | |
162 | elt | |
163 | (setq tmm-short-cuts (cons f tmm-short-cuts)) | |
164 | (cons (concat f tmm-mid-prompt str) (cdr elt))))) | |
165 | (reverse list))) | |
166 | ||
167 | (defun tmm-add-prompt () | |
168 | (remove-hook 'minibuffer-setup-hook 'tmm-add-prompt) | |
169 | (add-hook 'minibuffer-exit-hook 'tmm-delete-map) | |
170 | (let ((map (make-sparse-keymap)) (win (selected-window))) | |
171 | (mapcar (lambda (str) | |
172 | (define-key map str 'tmm-shortcut) | |
173 | (define-key map (downcase str) 'tmm-shortcut)) | |
174 | tmm-short-cuts) | |
175 | (define-key map [pageup] 'tmm-goto-completions) | |
176 | (define-key map [prior] 'tmm-goto-completions) | |
177 | (define-key map "\ev" 'tmm-goto-completions) | |
178 | (define-key map "\e\e" 'abort-recursive-edit) | |
179 | (setq tmm-old-mb-map (current-local-map)) | |
180 | (use-local-map (append map (cdr tmm-old-mb-map))) | |
181 | ;; Get window and hide it for electric mode to get correct size | |
182 | (save-window-excursion | |
183 | (minibuffer-completion-help) | |
184 | (set-buffer "*Completions*") | |
185 | (goto-char 1) | |
186 | (insert tmm-completion-prompt) | |
187 | ) | |
188 | (save-excursion | |
189 | (other-window 1) ; Electric-pop-up-window does | |
190 | ; not work in minibuffer | |
191 | (set-buffer (window-buffer (Electric-pop-up-window "*Completions*"))) | |
192 | (setq tmm-old-comp-map (current-local-map)) | |
193 | (use-local-map (append map (cdr tmm-old-comp-map))) | |
194 | (select-window win) ; Cannot use | |
195 | ; save-window-excursion, since | |
196 | ; it restores the size | |
197 | ) | |
198 | (insert tmm-c-prompt))) | |
199 | ||
200 | (defun tmm-delete-map () | |
201 | (remove-hook 'minibuffer-exit-hook 'tmm-delete-map) | |
202 | (use-local-map tmm-old-mb-map)) | |
203 | ||
204 | (defun tmm-shortcut () | |
205 | (interactive) | |
206 | (let ((c (upcase (char-to-string last-command-char))) s) | |
207 | (if (member c tmm-short-cuts) | |
208 | (if (equal (buffer-name) "*Completions*") | |
209 | (progn | |
210 | (beginning-of-buffer) | |
211 | (re-search-forward | |
212 | (concat "\\(^\\|[ \t]\\)" c tmm-mid-prompt)) | |
213 | (choose-completion)) | |
214 | (erase-buffer) ; In minibuffer | |
215 | (mapcar (lambda (elt) | |
216 | (if (string= | |
217 | (substring (car elt) 0 | |
218 | (min (1+ (length tmm-mid-prompt)) | |
219 | (length (car elt)))) | |
220 | (concat c tmm-mid-prompt)) | |
221 | (setq s (car elt)))) | |
222 | tmm-km-list) | |
223 | (insert s) | |
224 | (exit-minibuffer))))) | |
225 | ||
226 | (defun tmm-goto-completions () | |
227 | (interactive) | |
228 | (setq tmm-c-prompt (buffer-string)) | |
229 | (erase-buffer) | |
230 | (switch-to-buffer-other-window | |
231 | "*Completions*") | |
232 | (search-forward tmm-c-prompt) | |
233 | (search-backward tmm-c-prompt)) | |
234 | ||
235 | ||
236 | (defun tmm-get-keymap (elt &optional in-x-menu) | |
237 | "Prepends (DOCSTRING EVENT BINDING) to free variable `tmm-km-list'. | |
238 | The values are deduced from the argument ELT, that should be an | |
239 | element of keymap, on `x-popup-menu' argument, or an element of | |
240 | `x-popup-menu' argument (when IN-X-MENU is not-nil). | |
241 | Does it only if it is not already there. Uses free variable | |
242 | `tmm-table-undef' to keep undefined keys." | |
243 | (let (km str cache (event (car elt))) | |
244 | (setq elt (cdr elt)) | |
245 | (if (eq elt 'undefined) | |
246 | (setq tmm-table-undef (cons (cons event nil) tmm-table-undef)) | |
247 | (or | |
248 | (assoc event tmm-table-undef) | |
249 | (and (if (listp elt) | |
250 | (keymapp elt) | |
251 | (fboundp elt)) | |
252 | (setq km elt)) | |
253 | (and (if (listp (cdr-safe elt)) | |
254 | (keymapp (cdr-safe elt)) | |
255 | (fboundp (cdr-safe elt))) | |
256 | (setq km (cdr elt)) | |
257 | (and (stringp (car elt)) (setq str (car elt)))) | |
258 | (and (if (listp (cdr-safe (cdr-safe elt))) | |
259 | (keymapp (cdr-safe (cdr-safe elt))) | |
260 | (fboundp (cdr-safe (cdr-safe elt)))) | |
261 | (setq km (cdr (cdr elt))) | |
262 | (and (stringp (car elt)) (setq str (car elt))) | |
263 | (or (and str | |
264 | (stringp (cdr (car (cdr elt)))) ; keyseq cache | |
265 | (setq cache (cdr (car (cdr elt)))) | |
266 | cache (setq str (concat str cache))) str)) | |
267 | (and (if (listp (cdr-safe (cdr-safe (cdr-safe elt)))) | |
268 | (keymapp (cdr-safe (cdr-safe (cdr-safe elt)))) | |
269 | (fboundp (cdr-safe (cdr-safe (cdr-safe elt))))) | |
270 | ; New style of easy-menu | |
271 | (setq km (cdr (cdr (cdr elt)))) | |
272 | (and (stringp (car elt)) (setq str (car elt))) | |
273 | (or (and str | |
274 | (stringp (cdr (car (cdr (cdr elt))))) ; keyseq cache | |
275 | (setq cache (cdr (car (cdr (cdr elt))))) | |
276 | cache (setq str (concat str cache))) | |
277 | str)) | |
278 | (and (stringp event) ; x-popup or x-popup element | |
279 | (if (or in-x-menu (stringp (car-safe elt))) | |
280 | (setq str event event nil km elt) | |
281 | (setq str event event nil km (cons 'keymap elt)) | |
282 | ))) | |
283 | (and km (stringp km) (setq str km)) | |
284 | (and km str | |
285 | (or (assoc str tmm-km-list) | |
286 | (setq tmm-km-list | |
287 | (cons (cons str (cons event km)) tmm-km-list))) | |
288 | )))) | |
289 | ||
290 | ||
291 | (defun tmm-get-keybind (keyseq) | |
292 | "Gets binding from all the tables, can have some junk inside." | |
293 | (let (allbind bind) | |
294 | (setq allbind (mapcar 'cdr (minor-mode-key-binding keyseq))) | |
295 | (setq allbind (append allbind (list (local-key-binding keyseq)))) | |
296 | (setq allbind (append allbind (list (global-key-binding keyseq)))) | |
297 | ; list of bindings | |
298 | (mapcar (lambda (in) | |
299 | (if (and (symbolp in) (keymapp in)) | |
300 | (setq in (symbol-value in))) | |
301 | (and in | |
302 | (or (eq bind 'undefined) (not bind) | |
303 | (and (keymapp bind) (keymapp in))) | |
304 | (if (keymapp bind) | |
305 | (setq bind (append bind (cdr in))) | |
306 | (setq bind in) | |
307 | ) | |
308 | ) | |
309 | ) | |
310 | allbind) | |
311 | bind)) | |
312 | ||
313 | (add-hook 'calendar-load-hook (lambda () (require 'cal-menu))) | |
314 | ||
315 | ||
316 | (provide 'tmm) | |
317 | ||
318 | ||
319 | ;;; tmm.el ends here |