Mercurial > emacs
annotate lisp/tmm.el @ 13156:a398dbd2b945
Indentation change.
author | Richard M. Stallman <rms@gnu.org> |
---|---|
date | Sun, 08 Oct 1995 19:38:53 +0000 |
parents | 6db607a7b62d |
children | c55f17d3931f |
rev | line source |
---|---|
10955 | 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 | |
10956 | 7 ;; This file is part of GNU Emacs. |
10955 | 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 minibuffer-local-must-match-map [pageup] 'tmm-goto-completions) | |
36 ;(define-key minibuffer-local-must-match-map [prior] 'tmm-goto-completions) | |
37 ;(define-key minibuffer-local-must-match-map "\ev" 'tmm-goto-completions) | |
38 | |
39 ;;; The following will be localized, added only to pacify the compiler. | |
40 (defvar tmm-short-cuts) | |
41 (defvar tmm-old-mb-map) | |
42 (defvar tmm-old-comp-map) | |
43 (defvar tmm-c-prompt) | |
44 (defvar tmm-km-list) | |
45 (defvar tmm-table-undef) | |
46 | |
12960
6db607a7b62d
Fix typo in global-map define.
Richard M. Stallman <rms@gnu.org>
parents:
12763
diff
changeset
|
47 ;;;###autoload (define-key global-map "\M-`" 'tmm-menubar) |
12763
b8e986069a58
Don't alter bindings in minibuffer-local-must-match-map
Richard M. Stallman <rms@gnu.org>
parents:
10956
diff
changeset
|
48 |
10955 | 49 ;;;###autoload |
50 (defun tmm-menubar () | |
51 "Text-mode emulation of looking and choosing from a menubar. | |
52 See the documentation for `tmm-prompt'." | |
53 (interactive) | |
54 (run-hooks 'menu-bar-update-hook) | |
55 (tmm-prompt (tmm-get-keybind [menu-bar]))) | |
56 | |
57 (defvar tmm-mid-prompt "==>" | |
58 "String to insert between shortcut and menu item or nil.") | |
59 | |
60 (defvar tmm-mb-map nil | |
61 "A place to store minibuffer map.") | |
62 | |
63 (defvar tmm-completion-prompt | |
64 "Press PageUp Key to reach this buffer from the minibuffer. | |
65 Alternatively, you can use Up/Down keys (or your History keys) to change | |
66 the item in the minibuffer, and press RET when you are done, or press the | |
12763
b8e986069a58
Don't alter bindings in minibuffer-local-must-match-map
Richard M. Stallman <rms@gnu.org>
parents:
10956
diff
changeset
|
67 marked letters to pick up your choice. Type ESC ESC to cancel. |
10955 | 68 " |
69 "What insert on top of completion buffer.") | |
70 | |
71 ;;;###autoload | |
72 (defun tmm-prompt (bind &optional in-popup) | |
73 "Text-mode emulation of calling the bindings in keymap. | |
74 Creates a text-mode menu of possible choices. You can access the elements | |
75 in the menu: | |
76 *) Either via history mechanism from minibuffer; | |
77 *) Or via completion-buffer that is automatically shown. | |
78 The last alternative is currently a hack, you cannot use mouse reliably. | |
79 If the optional argument IN-POPUP is set, is argument-compatible with | |
80 `x-popup-menu', otherwise the argument BIND should be a cdr of sparse keymap." | |
81 (if in-popup (if bind (setq bind in-popup) (x-popup-menu nil in-popup))) | |
82 (let (gl-str tmm-km-list out compl-list compl-list-l tmm-table-undef tmm-c-prompt | |
83 tmm-old-mb-map tmm-old-comp-map tmm-short-cuts) | |
84 (run-hooks 'activate-menubar-hook) | |
85 (mapcar (function (lambda (elt) | |
86 (if (stringp elt) | |
87 (setq gl-str elt) | |
88 (and (listp elt) (tmm-get-keymap elt in-popup))) | |
89 )) bind) | |
90 (and tmm-km-list | |
91 (if tmm-mid-prompt | |
92 (setq tmm-km-list (reverse (tmm-add-shortcuts tmm-km-list))) | |
93 t) | |
94 (setq compl-list (mapcar 'car tmm-km-list)) | |
95 (setq compl-list-l (length compl-list)) | |
96 (setq compl-list (append compl-list compl-list compl-list compl-list)) | |
97 (setq tmm-c-prompt (nth (1- compl-list-l) compl-list)) | |
98 (add-hook 'minibuffer-setup-hook 'tmm-add-prompt) | |
99 (unwind-protect | |
100 (setq out | |
101 (completing-read | |
102 (concat gl-str " (up/down to change, PgUp to menu): ") | |
103 tmm-km-list nil t nil | |
104 (cons 'compl-list (* 2 compl-list-l)))) | |
105 ;;(add-hook 'minibuffer-setup-hook 'tmm-remove-shortcuts) | |
106 ;;(save-excursion | |
107 ;; (set-buffer "*Completions*") | |
108 ;; (use-local-map tmm-old-mb-map)) | |
109 (save-excursion | |
110 (set-buffer "*Completions*") | |
111 (use-local-map tmm-old-comp-map) | |
112 (bury-buffer (current-buffer))) | |
113 )) | |
114 (setq bind (cdr (assoc out tmm-km-list))) | |
115 (and (null bind) | |
116 (> (length out) (length tmm-c-prompt)) | |
117 (string= (substring out 0 (length tmm-c-prompt)) tmm-c-prompt) | |
118 (setq out (substring out (length tmm-c-prompt)) | |
119 bind (cdr (assoc out tmm-km-list)))) | |
120 (setq last-command-event (car bind)) | |
121 (setq bind (cdr bind)) | |
122 (if bind | |
123 (if in-popup (tmm-prompt t bind) | |
124 (if (keymapp bind) | |
125 (if (listp bind) | |
126 (progn | |
127 (condition-case nil | |
128 (require 'mouse) | |
129 (error nil)) | |
130 (condition-case nil | |
131 (x-popup-menu nil bind) ; Get the shortcuts | |
132 (error nil)) | |
133 (tmm-prompt bind)) | |
134 (tmm-prompt (symbol-value bind)) | |
135 ) | |
136 (if last-command-event | |
137 (call-interactively bind) | |
138 bind))) | |
139 gl-str))) | |
140 | |
141 (defun tmm-remove-shortcuts () | |
142 (use-local-map tmm-mb-map)) | |
143 | |
144 (defun tmm-add-shortcuts (list) | |
145 "Adds shortcuts to cars of elements of the list. | |
146 Takes a list of lists with a string as car, returns list with | |
147 shortcuts added to these cars. Adds the shortcuts to a free variable | |
148 `tmm-short-cuts'." | |
149 (mapcar (lambda (elt) | |
150 (let ((str (car elt)) f b) | |
151 (setq f (upcase (substring str 0 1))) | |
152 ;; If does not work, try beginning of the other word | |
153 (if (and (member f tmm-short-cuts) | |
154 (string-match " \\([^ ]\\)" str)) | |
155 (setq f (upcase (substring | |
156 str | |
157 (setq b (match-beginning 1)) (1+ b))))) | |
158 (if (member f tmm-short-cuts) | |
159 elt | |
160 (setq tmm-short-cuts (cons f tmm-short-cuts)) | |
161 (cons (concat f tmm-mid-prompt str) (cdr elt))))) | |
162 (reverse list))) | |
163 | |
164 (defun tmm-add-prompt () | |
165 (remove-hook 'minibuffer-setup-hook 'tmm-add-prompt) | |
12763
b8e986069a58
Don't alter bindings in minibuffer-local-must-match-map
Richard M. Stallman <rms@gnu.org>
parents:
10956
diff
changeset
|
166 (make-local-hook 'minibuffer-exit-hook) |
b8e986069a58
Don't alter bindings in minibuffer-local-must-match-map
Richard M. Stallman <rms@gnu.org>
parents:
10956
diff
changeset
|
167 (add-hook 'minibuffer-exit-hook 'tmm-delete-map nil t) |
10955 | 168 (let ((map (make-sparse-keymap)) (win (selected-window))) |
169 (mapcar (lambda (str) | |
170 (define-key map str 'tmm-shortcut) | |
171 (define-key map (downcase str) 'tmm-shortcut)) | |
172 tmm-short-cuts) | |
173 (define-key map [pageup] 'tmm-goto-completions) | |
174 (define-key map [prior] 'tmm-goto-completions) | |
175 (define-key map "\ev" 'tmm-goto-completions) | |
176 (define-key map "\e\e" 'abort-recursive-edit) | |
177 (setq tmm-old-mb-map (current-local-map)) | |
178 (use-local-map (append map (cdr tmm-old-mb-map))) | |
179 ;; Get window and hide it for electric mode to get correct size | |
180 (save-window-excursion | |
181 (minibuffer-completion-help) | |
182 (set-buffer "*Completions*") | |
183 (goto-char 1) | |
184 (insert tmm-completion-prompt) | |
185 ) | |
186 (save-excursion | |
187 (other-window 1) ; Electric-pop-up-window does | |
188 ; not work in minibuffer | |
189 (set-buffer (window-buffer (Electric-pop-up-window "*Completions*"))) | |
190 (setq tmm-old-comp-map (current-local-map)) | |
191 (use-local-map (append map (cdr tmm-old-comp-map))) | |
192 (select-window win) ; Cannot use | |
193 ; save-window-excursion, since | |
194 ; it restores the size | |
195 ) | |
196 (insert tmm-c-prompt))) | |
197 | |
198 (defun tmm-delete-map () | |
12763
b8e986069a58
Don't alter bindings in minibuffer-local-must-match-map
Richard M. Stallman <rms@gnu.org>
parents:
10956
diff
changeset
|
199 (remove-hook 'minibuffer-exit-hook 'tmm-delete-map t) |
10955 | 200 (use-local-map tmm-old-mb-map)) |
201 | |
202 (defun tmm-shortcut () | |
203 (interactive) | |
204 (let ((c (upcase (char-to-string last-command-char))) s) | |
205 (if (member c tmm-short-cuts) | |
206 (if (equal (buffer-name) "*Completions*") | |
207 (progn | |
208 (beginning-of-buffer) | |
209 (re-search-forward | |
210 (concat "\\(^\\|[ \t]\\)" c tmm-mid-prompt)) | |
211 (choose-completion)) | |
212 (erase-buffer) ; In minibuffer | |
213 (mapcar (lambda (elt) | |
214 (if (string= | |
215 (substring (car elt) 0 | |
216 (min (1+ (length tmm-mid-prompt)) | |
217 (length (car elt)))) | |
218 (concat c tmm-mid-prompt)) | |
219 (setq s (car elt)))) | |
220 tmm-km-list) | |
221 (insert s) | |
222 (exit-minibuffer))))) | |
223 | |
224 (defun tmm-goto-completions () | |
225 (interactive) | |
226 (setq tmm-c-prompt (buffer-string)) | |
227 (erase-buffer) | |
228 (switch-to-buffer-other-window | |
229 "*Completions*") | |
230 (search-forward tmm-c-prompt) | |
231 (search-backward tmm-c-prompt)) | |
232 | |
233 | |
234 (defun tmm-get-keymap (elt &optional in-x-menu) | |
235 "Prepends (DOCSTRING EVENT BINDING) to free variable `tmm-km-list'. | |
236 The values are deduced from the argument ELT, that should be an | |
237 element of keymap, on `x-popup-menu' argument, or an element of | |
238 `x-popup-menu' argument (when IN-X-MENU is not-nil). | |
239 Does it only if it is not already there. Uses free variable | |
240 `tmm-table-undef' to keep undefined keys." | |
241 (let (km str cache (event (car elt))) | |
242 (setq elt (cdr elt)) | |
243 (if (eq elt 'undefined) | |
244 (setq tmm-table-undef (cons (cons event nil) tmm-table-undef)) | |
245 (or | |
246 (assoc event tmm-table-undef) | |
247 (and (if (listp elt) | |
248 (keymapp elt) | |
249 (fboundp elt)) | |
250 (setq km elt)) | |
251 (and (if (listp (cdr-safe elt)) | |
252 (keymapp (cdr-safe elt)) | |
253 (fboundp (cdr-safe elt))) | |
254 (setq km (cdr elt)) | |
255 (and (stringp (car elt)) (setq str (car elt)))) | |
256 (and (if (listp (cdr-safe (cdr-safe elt))) | |
257 (keymapp (cdr-safe (cdr-safe elt))) | |
258 (fboundp (cdr-safe (cdr-safe elt)))) | |
259 (setq km (cdr (cdr elt))) | |
260 (and (stringp (car elt)) (setq str (car elt))) | |
261 (or (and str | |
262 (stringp (cdr (car (cdr elt)))) ; keyseq cache | |
263 (setq cache (cdr (car (cdr elt)))) | |
264 cache (setq str (concat str cache))) str)) | |
265 (and (if (listp (cdr-safe (cdr-safe (cdr-safe elt)))) | |
266 (keymapp (cdr-safe (cdr-safe (cdr-safe elt)))) | |
267 (fboundp (cdr-safe (cdr-safe (cdr-safe elt))))) | |
268 ; New style of easy-menu | |
269 (setq km (cdr (cdr (cdr elt)))) | |
270 (and (stringp (car elt)) (setq str (car elt))) | |
271 (or (and str | |
272 (stringp (cdr (car (cdr (cdr elt))))) ; keyseq cache | |
273 (setq cache (cdr (car (cdr (cdr elt))))) | |
274 cache (setq str (concat str cache))) | |
275 str)) | |
276 (and (stringp event) ; x-popup or x-popup element | |
277 (if (or in-x-menu (stringp (car-safe elt))) | |
278 (setq str event event nil km elt) | |
279 (setq str event event nil km (cons 'keymap elt)) | |
280 ))) | |
281 (and km (stringp km) (setq str km)) | |
282 (and km str | |
283 (or (assoc str tmm-km-list) | |
284 (setq tmm-km-list | |
285 (cons (cons str (cons event km)) tmm-km-list))) | |
286 )))) | |
287 | |
288 | |
289 (defun tmm-get-keybind (keyseq) | |
290 "Gets binding from all the tables, can have some junk inside." | |
291 (let (allbind bind) | |
292 (setq allbind (mapcar 'cdr (minor-mode-key-binding keyseq))) | |
293 (setq allbind (append allbind (list (local-key-binding keyseq)))) | |
294 (setq allbind (append allbind (list (global-key-binding keyseq)))) | |
295 ; list of bindings | |
296 (mapcar (lambda (in) | |
297 (if (and (symbolp in) (keymapp in)) | |
298 (setq in (symbol-value in))) | |
299 (and in | |
300 (or (eq bind 'undefined) (not bind) | |
301 (and (keymapp bind) (keymapp in))) | |
302 (if (keymapp bind) | |
303 (setq bind (append bind (cdr in))) | |
304 (setq bind in) | |
305 ) | |
306 ) | |
307 ) | |
308 allbind) | |
309 bind)) | |
310 | |
311 (add-hook 'calendar-load-hook (lambda () (require 'cal-menu))) | |
312 | |
313 | |
314 (provide 'tmm) | |
315 | |
316 | |
317 ;;; tmm.el ends here |