Mercurial > emacs
comparison lisp/obsolete/lmenu.el @ 111233:d86e0c3de741
merge trunk
author | Kenichi Handa <handa@m17n.org> |
---|---|
date | Thu, 14 Oct 2010 16:21:40 +0900 |
parents | lisp/emacs-lisp/lmenu.el@1d1d5d9bd884 lisp/emacs-lisp/lmenu.el@bec49af30c2f |
children |
comparison
equal
deleted
inserted
replaced
109848:637005c4c3ca | 111233:d86e0c3de741 |
---|---|
1 ;;; lmenu.el --- emulate Lucid's menubar support | |
2 | |
3 ;; Copyright (C) 1992, 1993, 1994, 1997, 2001, 2002, 2003, 2004, 2005, | |
4 ;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. | |
5 | |
6 ;; Keywords: emulations obsolete | |
7 ;; Obsolete-since: 23.3 | |
8 | |
9 ;; This file is part of GNU Emacs. | |
10 | |
11 ;; GNU Emacs is free software: you can redistribute it and/or modify | |
12 ;; it under the terms of the GNU General Public License as published by | |
13 ;; the Free Software Foundation, either version 3 of the License, or | |
14 ;; (at your option) any later version. | |
15 | |
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 | |
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
23 | |
24 ;;; Commentary: | |
25 | |
26 ;; This file has been obsolete since Emacs 23.3. | |
27 | |
28 ;;; Code: | |
29 | |
30 | |
31 ;; First, emulate the Lucid menubar support in GNU Emacs 19. | |
32 | |
33 ;; Arrange to use current-menubar to set up part of the menu bar. | |
34 | |
35 (defvar current-menubar) | |
36 (defvar lucid-menubar-map) | |
37 (defvar lucid-failing-menubar) | |
38 | |
39 (defvar recompute-lucid-menubar 'recompute-lucid-menubar) | |
40 (defun recompute-lucid-menubar () | |
41 (define-key lucid-menubar-map [menu-bar] | |
42 (condition-case nil | |
43 (make-lucid-menu-keymap "menu-bar" current-menubar) | |
44 (error (message "Invalid data in current-menubar moved to lucid-failing-menubar") | |
45 (sit-for 1) | |
46 (setq lucid-failing-menubar current-menubar | |
47 current-menubar nil)))) | |
48 (setq lucid-menu-bar-dirty-flag nil)) | |
49 | |
50 (defvar lucid-menubar-map (make-sparse-keymap)) | |
51 (or (assq 'current-menubar minor-mode-map-alist) | |
52 (setq minor-mode-map-alist | |
53 (cons (cons 'current-menubar lucid-menubar-map) | |
54 minor-mode-map-alist))) | |
55 | |
56 ;; XEmacs compatibility | |
57 (defun set-menubar-dirty-flag () | |
58 (force-mode-line-update) | |
59 (setq lucid-menu-bar-dirty-flag t)) | |
60 | |
61 (defvar add-menu-item-count 0) | |
62 | |
63 ;; This is a variable whose value is always nil. | |
64 (defvar make-lucid-menu-keymap-disable nil) | |
65 | |
66 ;; Return a menu keymap corresponding to a Lucid-style menu list | |
67 ;; MENU-ITEMS, and with name MENU-NAME. | |
68 (defun make-lucid-menu-keymap (menu-name menu-items) | |
69 (let ((menu (make-sparse-keymap menu-name))) | |
70 ;; Process items in reverse order, | |
71 ;; since the define-key loop reverses them again. | |
72 (setq menu-items (reverse menu-items)) | |
73 (while menu-items | |
74 (let ((item (car menu-items)) | |
75 command name callback) | |
76 (cond ((stringp item) | |
77 (setq command nil) | |
78 (setq name (if (string-match "^-+$" item) "" item))) | |
79 ((consp item) | |
80 (setq command (make-lucid-menu-keymap (car item) (cdr item))) | |
81 (setq name (car item))) | |
82 ((vectorp item) | |
83 (setq command (make-symbol (format "menu-function-%d" | |
84 add-menu-item-count)) | |
85 add-menu-item-count (1+ add-menu-item-count) | |
86 name (aref item 0) | |
87 callback (aref item 1)) | |
88 (if (symbolp callback) | |
89 (fset command callback) | |
90 (fset command (list 'lambda () '(interactive) callback))) | |
91 (put command 'menu-alias t) | |
92 (let ((i 2)) | |
93 (while (< i (length item)) | |
94 (cond | |
95 ((eq (aref item i) ':active) | |
96 (put command 'menu-enable | |
97 (or (aref item (1+ i)) | |
98 'make-lucid-menu-keymap-disable)) | |
99 (setq i (+ 2 i))) | |
100 ((eq (aref item i) ':suffix) | |
101 ;; unimplemented | |
102 (setq i (+ 2 i))) | |
103 ((eq (aref item i) ':keys) | |
104 ;; unimplemented | |
105 (setq i (+ 2 i))) | |
106 ((eq (aref item i) ':style) | |
107 ;; unimplemented | |
108 (setq i (+ 2 i))) | |
109 ((eq (aref item i) ':selected) | |
110 ;; unimplemented | |
111 (setq i (+ 2 i))) | |
112 ((and (symbolp (aref item i)) | |
113 (= ?: (string-to-char (symbol-name (aref item i))))) | |
114 (error "Unrecognized menu item keyword: %S" | |
115 (aref item i))) | |
116 ((= i 2) | |
117 ;; old-style format: active-p &optional suffix | |
118 (put command 'menu-enable | |
119 (or (aref item i) 'make-lucid-menu-keymap-disable)) | |
120 ;; suffix is unimplemented | |
121 (setq i (length item))) | |
122 (t | |
123 (error "Unexpected menu item value: %S" | |
124 (aref item i)))))))) | |
125 (if (null command) | |
126 ;; Handle inactive strings specially--allow any number | |
127 ;; of identical ones. | |
128 (setcdr menu (cons (list nil name) (cdr menu))) | |
129 (if name | |
130 (define-key menu (vector (intern name)) (cons name command))))) | |
131 (setq menu-items (cdr menu-items))) | |
132 menu)) | |
133 | |
134 (declare-function x-popup-dialog "xmenu.c" (position contents &optional header)) | |
135 | |
136 ;; XEmacs compatibility function | |
137 (defun popup-dialog-box (data) | |
138 "Pop up a dialog box. | |
139 A dialog box description is a list. | |
140 | |
141 - The first element of the list is a string to display in the dialog box. | |
142 - The rest of the elements are descriptions of the dialog box's buttons. | |
143 Each one is a vector of three elements: | |
144 - The first element is the text of the button. | |
145 - The second element is the `callback'. | |
146 - The third element is t or nil, whether this button is selectable. | |
147 | |
148 If the `callback' of a button is a symbol, then it must name a command. | |
149 It will be invoked with `call-interactively'. If it is a list, then it is | |
150 evaluated with `eval'. | |
151 | |
152 One (and only one) of the buttons may be nil. This marker means that all | |
153 following buttons should be flushright instead of flushleft. | |
154 | |
155 The syntax, more precisely: | |
156 | |
157 form := <something to pass to `eval'> | |
158 command := <a symbol or string, to pass to `call-interactively'> | |
159 callback := command | form | |
160 active-p := <t, nil, or a form to evaluate to decide whether this | |
161 button should be selectable> | |
162 name := <string> | |
163 partition := 'nil' | |
164 button := '[' name callback active-p ']' | |
165 dialog := '(' name [ button ]+ [ partition [ button ]+ ] ')'" | |
166 (let ((name (car data)) | |
167 (tail (cdr data)) | |
168 converted | |
169 choice meaning) | |
170 (while tail | |
171 (if (null (car tail)) | |
172 (setq converted (cons nil converted)) | |
173 (let ((item (aref (car tail) 0)) | |
174 (callback (aref (car tail) 1)) | |
175 (enable (aref (car tail) 2))) | |
176 (setq converted | |
177 (cons (if enable (cons item callback) item) | |
178 converted)))) | |
179 (setq tail (cdr tail))) | |
180 (setq choice (x-popup-dialog t (cons name (nreverse converted)))) | |
181 (if choice | |
182 (if (symbolp choice) | |
183 (call-interactively choice) | |
184 (eval choice))))) | |
185 | |
186 ;; This is empty because the usual elements of the menu bar | |
187 ;; are provided by menu-bar.el instead. | |
188 ;; It would not make sense to duplicate them here. | |
189 (defconst default-menubar nil) | |
190 | |
191 ;; XEmacs compatibility | |
192 (defun set-menubar (menubar) | |
193 "Set the default menubar to be menubar." | |
194 (setq-default current-menubar (copy-sequence menubar)) | |
195 (set-menubar-dirty-flag)) | |
196 | |
197 ;; XEmacs compatibility | |
198 (defun set-buffer-menubar (menubar) | |
199 "Set the buffer-local menubar to be menubar." | |
200 (make-local-variable 'current-menubar) | |
201 (setq current-menubar (copy-sequence menubar)) | |
202 (set-menubar-dirty-flag)) | |
203 | |
204 | |
205 ;;; menu manipulation functions | |
206 | |
207 ;; XEmacs compatibility | |
208 (defun find-menu-item (menubar item-path-list &optional parent) | |
209 "Searches MENUBAR for item given by ITEM-PATH-LIST. | |
210 Returns (ITEM . PARENT), where PARENT is the immediate parent of | |
211 the item found. | |
212 Signals an error if the item is not found." | |
213 (or parent (setq item-path-list (mapcar 'downcase item-path-list))) | |
214 (if (not (consp menubar)) | |
215 nil | |
216 (let ((rest menubar) | |
217 result) | |
218 (while rest | |
219 (if (and (car rest) | |
220 (equal (car item-path-list) | |
221 (downcase (if (vectorp (car rest)) | |
222 (aref (car rest) 0) | |
223 (if (stringp (car rest)) | |
224 (car rest) | |
225 (car (car rest))))))) | |
226 (setq result (car rest) rest nil) | |
227 (setq rest (cdr rest)))) | |
228 (if (cdr item-path-list) | |
229 (if (consp result) | |
230 (find-menu-item (cdr result) (cdr item-path-list) result) | |
231 (if result | |
232 (signal 'error (list "not a submenu" result)) | |
233 (signal 'error (list "no such submenu" (car item-path-list))))) | |
234 (cons result parent))))) | |
235 | |
236 | |
237 ;; XEmacs compatibility | |
238 (defun disable-menu-item (path) | |
239 "Make the named menu item be unselectable. | |
240 PATH is a list of strings which identify the position of the menu item in | |
241 the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" | |
242 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the | |
243 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." | |
244 (let* ((menubar current-menubar) | |
245 (pair (find-menu-item menubar path)) | |
246 (item (car pair)) | |
247 (menu (cdr pair))) | |
248 (or item | |
249 (signal 'error (list (if menu "No such menu item" "No such menu") | |
250 path))) | |
251 (if (consp item) (error "can't disable menus, only menu items")) | |
252 (aset item 2 nil) | |
253 (set-menubar-dirty-flag) | |
254 item)) | |
255 | |
256 | |
257 ;; XEmacs compatibility | |
258 (defun enable-menu-item (path) | |
259 "Make the named menu item be selectable. | |
260 PATH is a list of strings which identify the position of the menu item in | |
261 the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" | |
262 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the | |
263 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." | |
264 (let* ((menubar current-menubar) | |
265 (pair (find-menu-item menubar path)) | |
266 (item (car pair)) | |
267 (menu (cdr pair))) | |
268 (or item | |
269 (signal 'error (list (if menu "No such menu item" "No such menu") | |
270 path))) | |
271 (if (consp item) (error "%S is a menu, not a menu item" path)) | |
272 (aset item 2 t) | |
273 (set-menubar-dirty-flag) | |
274 item)) | |
275 | |
276 | |
277 (defun add-menu-item-1 (item-p menu-path item-name item-data enabled-p before) | |
278 (if before (setq before (downcase before))) | |
279 (let* ((menubar current-menubar) | |
280 (menu (condition-case () | |
281 (car (find-menu-item menubar menu-path)) | |
282 (error nil))) | |
283 (item (if (listp menu) | |
284 (car (find-menu-item (cdr menu) (list item-name))) | |
285 (signal 'error (list "not a submenu" menu-path))))) | |
286 (or menu | |
287 (let ((rest menu-path) | |
288 (so-far menubar)) | |
289 (while rest | |
290 ;;; (setq menu (car (find-menu-item (cdr so-far) (list (car rest))))) | |
291 (setq menu | |
292 (if (eq so-far menubar) | |
293 (car (find-menu-item so-far (list (car rest)))) | |
294 (car (find-menu-item (cdr so-far) (list (car rest)))))) | |
295 (or menu | |
296 (let ((rest2 so-far)) | |
297 (or rest2 | |
298 (error "Trying to modify a menu that doesn't exist")) | |
299 (while (and (cdr rest2) (car (cdr rest2))) | |
300 (setq rest2 (cdr rest2))) | |
301 (setcdr rest2 | |
302 (nconc (list (setq menu (list (car rest)))) | |
303 (cdr rest2))))) | |
304 (setq so-far menu) | |
305 (setq rest (cdr rest))))) | |
306 (or menu (setq menu menubar)) | |
307 (if item | |
308 nil ; it's already there | |
309 (if item-p | |
310 (setq item (vector item-name item-data enabled-p)) | |
311 (setq item (cons item-name item-data))) | |
312 ;; if BEFORE is specified, try to add it there. | |
313 (if before | |
314 (setq before (car (find-menu-item menu (list before))))) | |
315 (let ((rest menu) | |
316 (added-before nil)) | |
317 (while rest | |
318 (if (eq before (car (cdr rest))) | |
319 (progn | |
320 (setcdr rest (cons item (cdr rest))) | |
321 (setq rest nil added-before t)) | |
322 (setq rest (cdr rest)))) | |
323 (if (not added-before) | |
324 ;; adding before the first item on the menubar itself is harder | |
325 (if (and (eq menu menubar) (eq before (car menu))) | |
326 (setq menu (cons item menu) | |
327 current-menubar menu) | |
328 ;; otherwise, add the item to the end. | |
329 (nconc menu (list item)))))) | |
330 (if item-p | |
331 (progn | |
332 (aset item 1 item-data) | |
333 (aset item 2 (not (null enabled-p)))) | |
334 (setcar item item-name) | |
335 (setcdr item item-data)) | |
336 (set-menubar-dirty-flag) | |
337 item)) | |
338 | |
339 ;; XEmacs compatibility | |
340 (defun add-menu-item (menu-path item-name function enabled-p &optional before) | |
341 "Add a menu item to some menu, creating the menu first if necessary. | |
342 If the named item exists already, it is changed. | |
343 MENU-PATH identifies the menu under which the new menu item should be inserted. | |
344 It is a list of strings; for example, (\"File\") names the top-level \"File\" | |
345 menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". | |
346 ITEM-NAME is the string naming the menu item to be added. | |
347 FUNCTION is the command to invoke when this menu item is selected. | |
348 If it is a symbol, then it is invoked with `call-interactively', in the same | |
349 way that functions bound to keys are invoked. If it is a list, then the | |
350 list is simply evaluated. | |
351 ENABLED-P controls whether the item is selectable or not. | |
352 BEFORE, if provided, is the name of a menu item before which this item should | |
353 be added, if this item is not on the menu already. If the item is already | |
354 present, it will not be moved." | |
355 (or menu-path (error "must specify a menu path")) | |
356 (or item-name (error "must specify an item name")) | |
357 (add-menu-item-1 t menu-path item-name function enabled-p before)) | |
358 | |
359 | |
360 ;; XEmacs compatibility | |
361 (defun delete-menu-item (path) | |
362 "Remove the named menu item from the menu hierarchy. | |
363 PATH is a list of strings which identify the position of the menu item in | |
364 the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" | |
365 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the | |
366 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." | |
367 (let* ((menubar current-menubar) | |
368 (pair (find-menu-item menubar path)) | |
369 (item (car pair)) | |
370 (menu (or (cdr pair) menubar))) | |
371 (if (not item) | |
372 nil | |
373 ;; the menubar is the only special case, because other menus begin | |
374 ;; with their name. | |
375 (if (eq menu current-menubar) | |
376 (setq current-menubar (delq item menu)) | |
377 (delq item menu)) | |
378 (set-menubar-dirty-flag) | |
379 item))) | |
380 | |
381 | |
382 ;; XEmacs compatibility | |
383 (defun relabel-menu-item (path new-name) | |
384 "Change the string of the specified menu item. | |
385 PATH is a list of strings which identify the position of the menu item in | |
386 the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" | |
387 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the | |
388 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\". | |
389 NEW-NAME is the string that the menu item will be printed as from now on." | |
390 (or (stringp new-name) | |
391 (setq new-name (signal 'wrong-type-argument (list 'stringp new-name)))) | |
392 (let* ((menubar current-menubar) | |
393 (pair (find-menu-item menubar path)) | |
394 (item (car pair)) | |
395 (menu (cdr pair))) | |
396 (or item | |
397 (signal 'error (list (if menu "No such menu item" "No such menu") | |
398 path))) | |
399 (if (and (consp item) | |
400 (stringp (car item))) | |
401 (setcar item new-name) | |
402 (aset item 0 new-name)) | |
403 (set-menubar-dirty-flag) | |
404 item)) | |
405 | |
406 ;; XEmacs compatibility | |
407 (defun add-menu (menu-path menu-name menu-items &optional before) | |
408 "Add a menu to the menubar or one of its submenus. | |
409 If the named menu exists already, it is changed. | |
410 MENU-PATH identifies the menu under which the new menu should be inserted. | |
411 It is a list of strings; for example, (\"File\") names the top-level \"File\" | |
412 menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". | |
413 If MENU-PATH is nil, then the menu will be added to the menubar itself. | |
414 MENU-NAME is the string naming the menu to be added. | |
415 MENU-ITEMS is a list of menu item descriptions. | |
416 Each menu item should be a vector of three elements: | |
417 - a string, the name of the menu item; | |
418 - a symbol naming a command, or a form to evaluate; | |
419 - and a form whose value determines whether this item is selectable. | |
420 BEFORE, if provided, is the name of a menu before which this menu should | |
421 be added, if this menu is not on its parent already. If the menu is already | |
422 present, it will not be moved." | |
423 (or menu-name (error "must specify a menu name")) | |
424 (or menu-items (error "must specify some menu items")) | |
425 (add-menu-item-1 nil menu-path menu-name menu-items t before)) | |
426 | |
427 | |
428 | |
429 (defvar put-buffer-names-in-file-menu t) | |
430 | |
431 | |
432 ;; Don't unconditionally enable menu bars; leave that up to the user. | |
433 ;;(let ((frames (frame-list))) | |
434 ;; (while frames | |
435 ;; (modify-frame-parameters (car frames) '((menu-bar-lines . 1))) | |
436 ;; (setq frames (cdr frames)))) | |
437 ;;(or (assq 'menu-bar-lines default-frame-alist) | |
438 ;; (setq default-frame-alist | |
439 ;; (cons '(menu-bar-lines . 1) default-frame-alist))) | |
440 | |
441 (set-menubar default-menubar) | |
442 | |
443 (provide 'lmenu) | |
444 | |
445 ;;; lmenu.el ends here |