Mercurial > emacs
annotate lisp/emacs-lisp/lmenu.el @ 6357:fb5923ece02c
(VERTICAL_SCROLL_BAR_RIGHT_BORDER): Change from 3 to 2.
author | Karl Heuer <kwzh@gnu.org> |
---|---|
date | Tue, 15 Mar 1994 01:25:56 +0000 |
parents | a9f7e018245b |
children | 050f711140e0 |
rev | line source |
---|---|
2232
4f9d60f7de9d
Add standard library headers.
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
2231
diff
changeset
|
1 ;;; lmenu.el --- emulate Lucid's menubar support |
4f9d60f7de9d
Add standard library headers.
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
2231
diff
changeset
|
2 |
2233
fb0ed5a1d0f3
Add standard library headers.
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
2232
diff
changeset
|
3 ;; Keywords: emulations |
fb0ed5a1d0f3
Add standard library headers.
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
2232
diff
changeset
|
4 |
2231 | 5 ;; Copyright (C) 1992, 1993 Free Software Foundation, Inc. |
6 | |
7 ;; This file is part of GNU Emacs. | |
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 | |
2232
4f9d60f7de9d
Add standard library headers.
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
2231
diff
changeset
|
23 ;;; Code: |
4f9d60f7de9d
Add standard library headers.
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
2231
diff
changeset
|
24 |
2231 | 25 |
26 ;; First, emulate the Lucid menubar support in GNU Emacs 19. | |
27 | |
28 ;; Arrange to use current-menubar to set up part of the menu bar. | |
29 | |
30 (setq recompute-lucid-menubar 'recompute-lucid-menubar) | |
31 (defun recompute-lucid-menubar () | |
32 (define-key lucid-menubar-map [menu-bar] | |
33 (condition-case nil | |
34 (make-lucid-menu-keymap "menu-bar" current-menubar) | |
35 (error (message "Invalid data in current-menubar moved to lucid-failing-menubar") | |
36 (sit-for 1) | |
37 (setq lucid-failing-menubar current-menubar | |
38 current-menubar nil)))) | |
39 (setq lucid-menu-bar-dirty-flag nil)) | |
40 | |
41 (defvar lucid-menubar-map (make-sparse-keymap)) | |
42 (or (assq 'current-menubar minor-mode-map-alist) | |
43 (setq minor-mode-map-alist | |
44 (cons (cons 'current-menubar lucid-menubar-map) | |
45 minor-mode-map-alist))) | |
46 | |
47 (defun set-menubar-dirty-flag () | |
48 (force-mode-line-update) | |
49 (setq lucid-menu-bar-dirty-flag t)) | |
50 | |
51 (defvar add-menu-item-count 0) | |
52 | |
53 ;; Return a menu keymap corresponding to a Lucid-style menu list | |
54 ;; MENU-ITEMS, and with name MENU-NAME. | |
55 (defun make-lucid-menu-keymap (menu-name menu-items) | |
56 (let ((menu (make-sparse-keymap menu-name))) | |
57 ;; Process items in reverse order, | |
58 ;; since the define-key loop reverses them again. | |
59 (setq menu-items (reverse menu-items)) | |
60 (while menu-items | |
61 (let* ((item (car menu-items)) | |
62 (callback (if (vectorp item) (aref item 1))) | |
63 command enabler name) | |
64 (cond ((stringp item) | |
65 (setq command nil) | |
5461
5bb33851230e
(make-lucid-menu-keymap): For "----", make blank line.
Richard M. Stallman <rms@gnu.org>
parents:
5439
diff
changeset
|
66 (setq name (if (equal item "----") "" item))) |
2231 | 67 ((consp item) |
68 (setq command (make-lucid-menu-keymap (car item) (cdr item))) | |
69 (setq name (car item))) | |
70 ((vectorp item) | |
71 (setq command (make-symbol (format "menu-function-%d" | |
72 add-menu-item-count))) | |
73 (setq enabler (make-symbol (format "menu-function-%d-enabler" | |
74 add-menu-item-count))) | |
75 (setq add-menu-item-count (1+ add-menu-item-count)) | |
76 (put command 'menu-enable enabler) | |
77 (set enabler (aref item 2)) | |
78 (setq name (aref item 0)) | |
79 (if (symbolp callback) | |
80 (fset command callback) | |
81 (fset command (list 'lambda () '(interactive) callback))))) | |
5477
2efe469a9c24
(make-lucid-menu-keymap): Allow multiple identical inactive strings.
Richard M. Stallman <rms@gnu.org>
parents:
5461
diff
changeset
|
82 (if (null command) |
2efe469a9c24
(make-lucid-menu-keymap): Allow multiple identical inactive strings.
Richard M. Stallman <rms@gnu.org>
parents:
5461
diff
changeset
|
83 ;; Handle inactive strings specially--allow any number |
2efe469a9c24
(make-lucid-menu-keymap): Allow multiple identical inactive strings.
Richard M. Stallman <rms@gnu.org>
parents:
5461
diff
changeset
|
84 ;; of identical ones. |
2efe469a9c24
(make-lucid-menu-keymap): Allow multiple identical inactive strings.
Richard M. Stallman <rms@gnu.org>
parents:
5461
diff
changeset
|
85 (setcdr menu (cons (list nil name) (cdr menu))) |
2efe469a9c24
(make-lucid-menu-keymap): Allow multiple identical inactive strings.
Richard M. Stallman <rms@gnu.org>
parents:
5461
diff
changeset
|
86 (if name |
2efe469a9c24
(make-lucid-menu-keymap): Allow multiple identical inactive strings.
Richard M. Stallman <rms@gnu.org>
parents:
5461
diff
changeset
|
87 (define-key menu (vector (intern name)) (cons name command))))) |
2231 | 88 (setq menu-items (cdr menu-items))) |
89 menu)) | |
90 | |
91 (defun popup-menu (menu-desc) | |
92 "Pop up the given menu. | |
93 A menu is a list of menu items, strings, and submenus. | |
94 | |
95 The first element of a menu must be a string, which is the name of the | |
96 menu. This is the string that will be displayed in the parent menu, if | |
97 any. For toplevel menus, it is ignored. This string is not displayed | |
98 in the menu itself. | |
99 | |
100 A menu item is a vector of three or four elements: | |
101 | |
102 - the name of the menu item (a string); | |
103 - the `callback' of that item; | |
104 - whether this item is active (selectable); | |
105 - and an optional string to append to the name. | |
106 | |
107 If the `callback' of a menu item is a symbol, then it must name a command. | |
108 It will be invoked with `call-interactively'. If it is a list, then it is | |
109 evaluated with `eval'. | |
110 | |
111 The fourth element of a menu item is a convenient way of adding the name | |
112 of a command's ``argument'' to the menu, like ``Kill Buffer NAME''. | |
113 | |
114 If an element of a menu is a string, then that string will be presented in | |
115 the menu as unselectable text. | |
116 | |
117 If an element of a menu is a string consisting solely of hyphens, then that | |
118 item will be presented as a solid horizontal line. | |
119 | |
120 If an element of a menu is a list, it is treated as a submenu. The name of | |
121 that submenu (the first element in the list) will be used as the name of the | |
122 item representing this menu on the parent. | |
123 | |
124 The syntax, more precisely: | |
125 | |
126 form := <something to pass to `eval'> | |
127 command := <a symbol or string, to pass to `call-interactively'> | |
128 callback := command | form | |
129 active-p := <t or nil, whether this thing is selectable> | |
130 text := <string, non selectable> | |
131 name := <string> | |
132 argument := <string> | |
133 menu-item := '[' name callback active-p [ argument ] ']' | |
134 menu := '(' name [ menu-item | menu | text ]+ ')' | |
135 " | |
136 (let ((menu (make-lucid-menu-keymap (car menu-desc) (cdr menu-desc))) | |
137 (pos (mouse-position)) | |
138 answer) | |
5439
77798fccc85c
(popup-menu): Add loop to handle submenus.
Richard M. Stallman <rms@gnu.org>
parents:
2751
diff
changeset
|
139 (while menu |
77798fccc85c
(popup-menu): Add loop to handle submenus.
Richard M. Stallman <rms@gnu.org>
parents:
2751
diff
changeset
|
140 (setq answer (x-popup-menu (list (list (nth 1 pos) (nthcdr 2 pos)) |
77798fccc85c
(popup-menu): Add loop to handle submenus.
Richard M. Stallman <rms@gnu.org>
parents:
2751
diff
changeset
|
141 (car pos)) |
77798fccc85c
(popup-menu): Add loop to handle submenus.
Richard M. Stallman <rms@gnu.org>
parents:
2751
diff
changeset
|
142 menu)) |
77798fccc85c
(popup-menu): Add loop to handle submenus.
Richard M. Stallman <rms@gnu.org>
parents:
2751
diff
changeset
|
143 (setq cmd (lookup-key menu (vector answer))) |
77798fccc85c
(popup-menu): Add loop to handle submenus.
Richard M. Stallman <rms@gnu.org>
parents:
2751
diff
changeset
|
144 (setq menu nil) |
77798fccc85c
(popup-menu): Add loop to handle submenus.
Richard M. Stallman <rms@gnu.org>
parents:
2751
diff
changeset
|
145 (and cmd |
77798fccc85c
(popup-menu): Add loop to handle submenus.
Richard M. Stallman <rms@gnu.org>
parents:
2751
diff
changeset
|
146 (if (keymapp cmd) |
77798fccc85c
(popup-menu): Add loop to handle submenus.
Richard M. Stallman <rms@gnu.org>
parents:
2751
diff
changeset
|
147 (setq menu cmd) |
77798fccc85c
(popup-menu): Add loop to handle submenus.
Richard M. Stallman <rms@gnu.org>
parents:
2751
diff
changeset
|
148 (call-interactively cmd)))))) |
2231 | 149 |
2751
f95808ad4b95
(default-menubar): Make initial value nil.
Richard M. Stallman <rms@gnu.org>
parents:
2233
diff
changeset
|
150 ;; This is empty because the usual elements of the menu bar |
f95808ad4b95
(default-menubar): Make initial value nil.
Richard M. Stallman <rms@gnu.org>
parents:
2233
diff
changeset
|
151 ;; are provided by menu-bar.el instead. |
f95808ad4b95
(default-menubar): Make initial value nil.
Richard M. Stallman <rms@gnu.org>
parents:
2233
diff
changeset
|
152 ;; It would not make sense to duplicate them here. |
f95808ad4b95
(default-menubar): Make initial value nil.
Richard M. Stallman <rms@gnu.org>
parents:
2233
diff
changeset
|
153 (defconst default-menubar nil) |
2231 | 154 |
155 (defun set-menubar (menubar) | |
156 "Set the default menubar to be menubar." | |
157 (setq-default current-menubar (copy-sequence menubar)) | |
158 (set-menubar-dirty-flag)) | |
159 | |
160 (defun set-buffer-menubar (menubar) | |
161 "Set the buffer-local menubar to be menubar." | |
162 (make-local-variable 'current-menubar) | |
163 (setq current-menubar (copy-sequence menubar)) | |
164 (set-menubar-dirty-flag)) | |
165 | |
166 | |
167 ;;; menu manipulation functions | |
168 | |
169 (defun find-menu-item (menubar item-path-list &optional parent) | |
170 "Searches MENUBAR for item given by ITEM-PATH-LIST. | |
171 Returns (ITEM . PARENT), where PARENT is the immediate parent of | |
172 the item found. | |
173 Signals an error if the item is not found." | |
174 (or parent (setq item-path-list (mapcar 'downcase item-path-list))) | |
175 (if (not (consp menubar)) | |
176 nil | |
177 (let ((rest menubar) | |
178 result) | |
179 (while rest | |
180 (if (and (car rest) | |
181 (equal (car item-path-list) | |
182 (downcase (if (vectorp (car rest)) | |
183 (aref (car rest) 0) | |
184 (if (stringp (car rest)) | |
185 (car rest) | |
186 (car (car rest))))))) | |
187 (setq result (car rest) rest nil) | |
188 (setq rest (cdr rest)))) | |
189 (if (cdr item-path-list) | |
190 (if (consp result) | |
191 (find-menu-item (cdr result) (cdr item-path-list) result) | |
192 (if result | |
193 (signal 'error (list "not a submenu" result)) | |
194 (signal 'error (list "no such submenu" (car item-path-list))))) | |
195 (cons result parent))))) | |
196 | |
197 | |
198 (defun disable-menu-item (path) | |
199 "Make the named menu item be unselectable. | |
200 PATH is a list of strings which identify the position of the menu item in | |
201 the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" | |
202 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the | |
203 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." | |
204 (let* ((menubar current-menubar) | |
205 (pair (find-menu-item menubar path)) | |
206 (item (car pair)) | |
207 (menu (cdr pair))) | |
208 (or item | |
209 (signal 'error (list (if menu "No such menu item" "No such menu") | |
210 path))) | |
211 (if (consp item) (error "can't disable menus, only menu items")) | |
212 (aset item 2 nil) | |
213 (set-menubar-dirty-flag) | |
214 item)) | |
215 | |
216 | |
217 (defun enable-menu-item (path) | |
218 "Make the named menu item be selectable. | |
219 PATH is a list of strings which identify the position of the menu item in | |
220 the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" | |
221 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the | |
222 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." | |
223 (let* ((menubar current-menubar) | |
224 (pair (find-menu-item menubar path)) | |
225 (item (car pair)) | |
226 (menu (cdr pair))) | |
227 (or item | |
228 (signal 'error (list (if menu "No such menu item" "No such menu") | |
229 path))) | |
230 (if (consp item) (error "%S is a menu, not a menu item" path)) | |
231 (aset item 2 t) | |
232 (set-menubar-dirty-flag) | |
233 item)) | |
234 | |
235 | |
236 (defun add-menu-item-1 (item-p menu-path item-name item-data enabled-p before) | |
237 (if before (setq before (downcase before))) | |
238 (let* ((menubar current-menubar) | |
239 (menu (condition-case () | |
240 (car (find-menu-item menubar menu-path)) | |
241 (error nil))) | |
242 (item (if (listp menu) | |
243 (car (find-menu-item (cdr menu) (list item-name))) | |
244 (signal 'error (list "not a submenu" menu-path))))) | |
245 (or menu | |
246 (let ((rest menu-path) | |
247 (so-far menubar)) | |
248 (while rest | |
249 ;;; (setq menu (car (find-menu-item (cdr so-far) (list (car rest))))) | |
250 (setq menu | |
251 (if (eq so-far menubar) | |
252 (car (find-menu-item so-far (list (car rest)))) | |
253 (car (find-menu-item (cdr so-far) (list (car rest)))))) | |
254 (or menu | |
255 (let ((rest2 so-far)) | |
256 (while (and (cdr rest2) (car (cdr rest2))) | |
257 (setq rest2 (cdr rest2))) | |
258 (setcdr rest2 | |
259 (nconc (list (setq menu (list (car rest)))) | |
260 (cdr rest2))))) | |
261 (setq so-far menu) | |
262 (setq rest (cdr rest))))) | |
263 (or menu (setq menu menubar)) | |
264 (if item | |
265 nil ; it's already there | |
266 (if item-p | |
267 (setq item (vector item-name item-data enabled-p)) | |
268 (setq item (cons item-name item-data))) | |
269 ;; if BEFORE is specified, try to add it there. | |
270 (if before | |
271 (setq before (car (find-menu-item menu (list before))))) | |
272 (let ((rest menu) | |
273 (added-before nil)) | |
274 (while rest | |
275 (if (eq before (car (cdr rest))) | |
276 (progn | |
277 (setcdr rest (cons item (cdr rest))) | |
278 (setq rest nil added-before t)) | |
279 (setq rest (cdr rest)))) | |
280 (if (not added-before) | |
281 ;; adding before the first item on the menubar itself is harder | |
282 (if (and (eq menu menubar) (eq before (car menu))) | |
283 (setq menu (cons item menu) | |
284 current-menubar menu) | |
285 ;; otherwise, add the item to the end. | |
286 (nconc menu (list item)))))) | |
287 (if item-p | |
288 (progn | |
289 (aset item 1 item-data) | |
290 (aset item 2 (not (null enabled-p)))) | |
291 (setcar item item-name) | |
292 (setcdr item item-data)) | |
293 (set-menubar-dirty-flag) | |
294 item)) | |
295 | |
296 (defun add-menu-item (menu-path item-name function enabled-p &optional before) | |
297 "Add a menu item to some menu, creating the menu first if necessary. | |
298 If the named item exists already, it is changed. | |
299 MENU-PATH identifies the menu under which the new menu item should be inserted. | |
300 It is a list of strings; for example, (\"File\") names the top-level \"File\" | |
301 menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". | |
302 ITEM-NAME is the string naming the menu item to be added. | |
303 FUNCTION is the command to invoke when this menu item is selected. | |
304 If it is a symbol, then it is invoked with `call-interactively', in the same | |
305 way that functions bound to keys are invoked. If it is a list, then the | |
306 list is simply evaluated. | |
307 ENABLED-P controls whether the item is selectable or not. | |
308 BEFORE, if provided, is the name of a menu item before which this item should | |
309 be added, if this item is not on the menu already. If the item is already | |
310 present, it will not be moved." | |
311 (or menu-path (error "must specify a menu path")) | |
312 (or item-name (error "must specify an item name")) | |
313 (add-menu-item-1 t menu-path item-name function enabled-p before)) | |
314 | |
315 | |
316 (defun delete-menu-item (path) | |
317 "Remove the named menu item from the menu hierarchy. | |
318 PATH is a list of strings which identify the position of the menu item in | |
319 the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" | |
320 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the | |
321 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." | |
322 (let* ((menubar current-menubar) | |
323 (pair (find-menu-item menubar path)) | |
324 (item (car pair)) | |
325 (menu (or (cdr pair) menubar))) | |
326 (if (not item) | |
327 nil | |
328 ;; the menubar is the only special case, because other menus begin | |
329 ;; with their name. | |
330 (if (eq menu current-menubar) | |
331 (setq current-menubar (delq item menu)) | |
332 (delq item menu)) | |
333 (set-menubar-dirty-flag) | |
334 item))) | |
335 | |
336 | |
337 (defun relabel-menu-item (path new-name) | |
338 "Change the string of the specified menu item. | |
339 PATH is a list of strings which identify the position of the menu item in | |
340 the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" | |
341 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the | |
342 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\". | |
343 NEW-NAME is the string that the menu item will be printed as from now on." | |
344 (or (stringp new-name) | |
345 (setq new-name (signal 'wrong-type-argument (list 'stringp new-name)))) | |
346 (let* ((menubar current-menubar) | |
347 (pair (find-menu-item menubar path)) | |
348 (item (car pair)) | |
349 (menu (cdr pair))) | |
350 (or item | |
351 (signal 'error (list (if menu "No such menu item" "No such menu") | |
352 path))) | |
353 (if (and (consp item) | |
354 (stringp (car item))) | |
355 (setcar item new-name) | |
356 (aset item 0 new-name)) | |
357 (set-menubar-dirty-flag) | |
358 item)) | |
359 | |
360 (defun add-menu (menu-path menu-name menu-items &optional before) | |
361 "Add a menu to the menubar or one of its submenus. | |
362 If the named menu exists already, it is changed. | |
363 MENU-PATH identifies the menu under which the new menu should be inserted. | |
364 It is a list of strings; for example, (\"File\") names the top-level \"File\" | |
365 menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". | |
366 If MENU-PATH is nil, then the menu will be added to the menubar itself. | |
367 MENU-NAME is the string naming the menu to be added. | |
368 MENU-ITEMS is a list of menu item descriptions. | |
369 Each menu item should be a vector of three elements: | |
370 - a string, the name of the menu item; | |
371 - a symbol naming a command, or a form to evaluate; | |
372 - and t or nil, whether this item is selectable. | |
373 BEFORE, if provided, is the name of a menu before which this menu should | |
374 be added, if this menu is not on its parent already. If the menu is already | |
375 present, it will not be moved." | |
376 (or menu-name (error "must specify a menu name")) | |
377 (or menu-items (error "must specify some menu items")) | |
378 (add-menu-item-1 nil menu-path menu-name menu-items t before)) | |
379 | |
380 | |
381 | |
382 (defvar put-buffer-names-in-file-menu t) | |
383 | |
384 | |
5982
a9f7e018245b
Delete the code to enable menu bars.
Richard M. Stallman <rms@gnu.org>
parents:
5477
diff
changeset
|
385 ;; Don't unconditionally enable menu bars; leave that up to the user. |
a9f7e018245b
Delete the code to enable menu bars.
Richard M. Stallman <rms@gnu.org>
parents:
5477
diff
changeset
|
386 ;;(let ((frames (frame-list))) |
a9f7e018245b
Delete the code to enable menu bars.
Richard M. Stallman <rms@gnu.org>
parents:
5477
diff
changeset
|
387 ;; (while frames |
a9f7e018245b
Delete the code to enable menu bars.
Richard M. Stallman <rms@gnu.org>
parents:
5477
diff
changeset
|
388 ;; (modify-frame-parameters (car frames) '((menu-bar-lines . 1))) |
a9f7e018245b
Delete the code to enable menu bars.
Richard M. Stallman <rms@gnu.org>
parents:
5477
diff
changeset
|
389 ;; (setq frames (cdr frames)))) |
a9f7e018245b
Delete the code to enable menu bars.
Richard M. Stallman <rms@gnu.org>
parents:
5477
diff
changeset
|
390 ;;(or (assq 'menu-bar-lines default-frame-alist) |
a9f7e018245b
Delete the code to enable menu bars.
Richard M. Stallman <rms@gnu.org>
parents:
5477
diff
changeset
|
391 ;; (setq default-frame-alist |
a9f7e018245b
Delete the code to enable menu bars.
Richard M. Stallman <rms@gnu.org>
parents:
5477
diff
changeset
|
392 ;; (cons '(menu-bar-lines . 1) default-frame-alist))) |
2231 | 393 |
394 (set-menubar default-menubar) | |
395 | |
396 (provide 'menubar) | |
397 | |
2232
4f9d60f7de9d
Add standard library headers.
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
2231
diff
changeset
|
398 ;;; lmenu.el ends here |