2231
|
1 ;;; Menubar support.
|
|
2 ;; Copyright (C) 1992, 1993 Free Software Foundation, Inc.
|
|
3
|
|
4 ;; This file is part of GNU Emacs.
|
|
5
|
|
6 ;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
7 ;; it under the terms of the GNU General Public License as published by
|
|
8 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
9 ;; any later version.
|
|
10
|
|
11 ;; GNU Emacs is distributed in the hope that it will be useful,
|
|
12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
14 ;; GNU General Public License for more details.
|
|
15
|
|
16 ;; You should have received a copy of the GNU General Public License
|
|
17 ;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
18 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
19
|
|
20
|
|
21 ;; First, emulate the Lucid menubar support in GNU Emacs 19.
|
|
22
|
|
23 ;; Arrange to use current-menubar to set up part of the menu bar.
|
|
24
|
|
25 (setq recompute-lucid-menubar 'recompute-lucid-menubar)
|
|
26 (defun recompute-lucid-menubar ()
|
|
27 (define-key lucid-menubar-map [menu-bar]
|
|
28 (condition-case nil
|
|
29 (make-lucid-menu-keymap "menu-bar" current-menubar)
|
|
30 (error (message "Invalid data in current-menubar moved to lucid-failing-menubar")
|
|
31 (sit-for 1)
|
|
32 (setq lucid-failing-menubar current-menubar
|
|
33 current-menubar nil))))
|
|
34 (setq lucid-menu-bar-dirty-flag nil))
|
|
35
|
|
36 (defvar lucid-menubar-map (make-sparse-keymap))
|
|
37 (or (assq 'current-menubar minor-mode-map-alist)
|
|
38 (setq minor-mode-map-alist
|
|
39 (cons (cons 'current-menubar lucid-menubar-map)
|
|
40 minor-mode-map-alist)))
|
|
41
|
|
42 (defun set-menubar-dirty-flag ()
|
|
43 (force-mode-line-update)
|
|
44 (setq lucid-menu-bar-dirty-flag t))
|
|
45
|
|
46 (defvar add-menu-item-count 0)
|
|
47
|
|
48 ;; Return a menu keymap corresponding to a Lucid-style menu list
|
|
49 ;; MENU-ITEMS, and with name MENU-NAME.
|
|
50 (defun make-lucid-menu-keymap (menu-name menu-items)
|
|
51 (let ((menu (make-sparse-keymap menu-name)))
|
|
52 ;; Process items in reverse order,
|
|
53 ;; since the define-key loop reverses them again.
|
|
54 (setq menu-items (reverse menu-items))
|
|
55 (while menu-items
|
|
56 (let* ((item (car menu-items))
|
|
57 (callback (if (vectorp item) (aref item 1)))
|
|
58 command enabler name)
|
|
59 (cond ((stringp item)
|
|
60 (setq command nil)
|
|
61 (setq name item))
|
|
62 ((consp item)
|
|
63 (setq command (make-lucid-menu-keymap (car item) (cdr item)))
|
|
64 (setq name (car item)))
|
|
65 ((vectorp item)
|
|
66 (setq command (make-symbol (format "menu-function-%d"
|
|
67 add-menu-item-count)))
|
|
68 (setq enabler (make-symbol (format "menu-function-%d-enabler"
|
|
69 add-menu-item-count)))
|
|
70 (setq add-menu-item-count (1+ add-menu-item-count))
|
|
71 (put command 'menu-enable enabler)
|
|
72 (set enabler (aref item 2))
|
|
73 (setq name (aref item 0))
|
|
74 (if (symbolp callback)
|
|
75 (fset command callback)
|
|
76 (fset command (list 'lambda () '(interactive) callback)))))
|
|
77 (if name
|
|
78 (define-key menu (vector (intern name)) (cons name command))))
|
|
79 (setq menu-items (cdr menu-items)))
|
|
80 menu))
|
|
81
|
|
82 (defun popup-menu (menu-desc)
|
|
83 "Pop up the given menu.
|
|
84 A menu is a list of menu items, strings, and submenus.
|
|
85
|
|
86 The first element of a menu must be a string, which is the name of the
|
|
87 menu. This is the string that will be displayed in the parent menu, if
|
|
88 any. For toplevel menus, it is ignored. This string is not displayed
|
|
89 in the menu itself.
|
|
90
|
|
91 A menu item is a vector of three or four elements:
|
|
92
|
|
93 - the name of the menu item (a string);
|
|
94 - the `callback' of that item;
|
|
95 - whether this item is active (selectable);
|
|
96 - and an optional string to append to the name.
|
|
97
|
|
98 If the `callback' of a menu item is a symbol, then it must name a command.
|
|
99 It will be invoked with `call-interactively'. If it is a list, then it is
|
|
100 evaluated with `eval'.
|
|
101
|
|
102 The fourth element of a menu item is a convenient way of adding the name
|
|
103 of a command's ``argument'' to the menu, like ``Kill Buffer NAME''.
|
|
104
|
|
105 If an element of a menu is a string, then that string will be presented in
|
|
106 the menu as unselectable text.
|
|
107
|
|
108 If an element of a menu is a string consisting solely of hyphens, then that
|
|
109 item will be presented as a solid horizontal line.
|
|
110
|
|
111 If an element of a menu is a list, it is treated as a submenu. The name of
|
|
112 that submenu (the first element in the list) will be used as the name of the
|
|
113 item representing this menu on the parent.
|
|
114
|
|
115 The syntax, more precisely:
|
|
116
|
|
117 form := <something to pass to `eval'>
|
|
118 command := <a symbol or string, to pass to `call-interactively'>
|
|
119 callback := command | form
|
|
120 active-p := <t or nil, whether this thing is selectable>
|
|
121 text := <string, non selectable>
|
|
122 name := <string>
|
|
123 argument := <string>
|
|
124 menu-item := '[' name callback active-p [ argument ] ']'
|
|
125 menu := '(' name [ menu-item | menu | text ]+ ')'
|
|
126 "
|
|
127 (let ((menu (make-lucid-menu-keymap (car menu-desc) (cdr menu-desc)))
|
|
128 (pos (mouse-position))
|
|
129 answer)
|
|
130 (setq answer (x-popup-menu (list (list (nth 1 pos) (nthcdr 2 pos))
|
|
131 (car pos))
|
|
132 menu))
|
|
133 (setq cmd (lookup-key menu (vector answer)))
|
|
134 (if cmd (call-interactively cmd))))
|
|
135
|
|
136 (defconst default-menubar
|
|
137 '(("File" ["New Frame" x-new-frame t]
|
|
138 ["Open File..." find-file t]
|
|
139 ["Save Buffer" save-buffer t nil]
|
|
140 ["Save Buffer As..." write-file t]
|
|
141 ["Revert Buffer" revert-buffer t nil]
|
|
142 "-----"
|
|
143 ["Print Buffer" lpr-buffer t nil]
|
|
144 "-----"
|
|
145 ["Delete Frame" delete-frame t]
|
|
146 ;; ["Kill Buffer..." kill-buffer t]
|
|
147 ["Kill Buffer" kill-this-buffer t nil]
|
|
148 ["Exit Emacs" save-buffers-kill-emacs t]
|
|
149 )
|
|
150 ("Edit" ["Undo" advertised-undo t]
|
|
151 ["Cut" x-kill-primary-selection t]
|
|
152 ["Copy" x-copy-primary-selection t]
|
|
153 ["Paste" x-yank-clipboard-selection t]
|
|
154 ["Clear" x-delete-primary-selection t]
|
|
155 )
|
|
156 ("Buffers" "")
|
|
157
|
|
158 nil ; the partition: menus after this are flushright
|
|
159
|
|
160 ("Help" ["Info" info t]
|
|
161 ["Describe Mode" describe-mode t]
|
|
162 ["Command Apropos..." command-apropos t]
|
|
163 ["List Keybindings" describe-bindings t]
|
|
164 ["Describe Key..." describe-key t]
|
|
165 ["Describe Function..." describe-function t]
|
|
166 ["Describe Variable..." describe-variable t]
|
|
167 "-----"
|
|
168 ["Man..." manual-entry t]
|
|
169 ["Emacs Tutorial" help-with-tutorial t]
|
|
170 ["Emacs News" view-emacs-news t]
|
|
171 )
|
|
172 ))
|
|
173
|
|
174
|
|
175 (defun kill-this-buffer () ; for the menubar
|
|
176 "Kills the current buffer."
|
|
177 (interactive)
|
|
178 (kill-buffer (current-buffer)))
|
|
179
|
|
180 (defun x-new-frame (&optional frame-name)
|
|
181 "Creates a new Emacs frame (that is, a new X window.)"
|
|
182 (interactive)
|
|
183 (select-frame (x-create-frame
|
|
184 (append (if frame-name
|
|
185 (list (cons 'name frame-name))
|
|
186 nil)
|
|
187 frame-default-alist)))
|
|
188 (switch-to-buffer (get-buffer-create "*scratch*"))
|
|
189 )
|
|
190
|
|
191 (defun set-menubar (menubar)
|
|
192 "Set the default menubar to be menubar."
|
|
193 (setq-default current-menubar (copy-sequence menubar))
|
|
194 (set-menubar-dirty-flag))
|
|
195
|
|
196 (defun set-buffer-menubar (menubar)
|
|
197 "Set the buffer-local menubar to be menubar."
|
|
198 (make-local-variable 'current-menubar)
|
|
199 (setq current-menubar (copy-sequence menubar))
|
|
200 (set-menubar-dirty-flag))
|
|
201
|
|
202
|
|
203 ;;; menu manipulation functions
|
|
204
|
|
205 (defun find-menu-item (menubar item-path-list &optional parent)
|
|
206 "Searches MENUBAR for item given by ITEM-PATH-LIST.
|
|
207 Returns (ITEM . PARENT), where PARENT is the immediate parent of
|
|
208 the item found.
|
|
209 Signals an error if the item is not found."
|
|
210 (or parent (setq item-path-list (mapcar 'downcase item-path-list)))
|
|
211 (if (not (consp menubar))
|
|
212 nil
|
|
213 (let ((rest menubar)
|
|
214 result)
|
|
215 (while rest
|
|
216 (if (and (car rest)
|
|
217 (equal (car item-path-list)
|
|
218 (downcase (if (vectorp (car rest))
|
|
219 (aref (car rest) 0)
|
|
220 (if (stringp (car rest))
|
|
221 (car rest)
|
|
222 (car (car rest)))))))
|
|
223 (setq result (car rest) rest nil)
|
|
224 (setq rest (cdr rest))))
|
|
225 (if (cdr item-path-list)
|
|
226 (if (consp result)
|
|
227 (find-menu-item (cdr result) (cdr item-path-list) result)
|
|
228 (if result
|
|
229 (signal 'error (list "not a submenu" result))
|
|
230 (signal 'error (list "no such submenu" (car item-path-list)))))
|
|
231 (cons result parent)))))
|
|
232
|
|
233
|
|
234 (defun disable-menu-item (path)
|
|
235 "Make the named menu item be unselectable.
|
|
236 PATH is a list of strings which identify the position of the menu item in
|
|
237 the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\"
|
|
238 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the
|
|
239 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
|
|
240 (let* ((menubar current-menubar)
|
|
241 (pair (find-menu-item menubar path))
|
|
242 (item (car pair))
|
|
243 (menu (cdr pair)))
|
|
244 (or item
|
|
245 (signal 'error (list (if menu "No such menu item" "No such menu")
|
|
246 path)))
|
|
247 (if (consp item) (error "can't disable menus, only menu items"))
|
|
248 (aset item 2 nil)
|
|
249 (set-menubar-dirty-flag)
|
|
250 item))
|
|
251
|
|
252
|
|
253 (defun enable-menu-item (path)
|
|
254 "Make the named menu item be selectable.
|
|
255 PATH is a list of strings which identify the position of the menu item in
|
|
256 the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\"
|
|
257 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the
|
|
258 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
|
|
259 (let* ((menubar current-menubar)
|
|
260 (pair (find-menu-item menubar path))
|
|
261 (item (car pair))
|
|
262 (menu (cdr pair)))
|
|
263 (or item
|
|
264 (signal 'error (list (if menu "No such menu item" "No such menu")
|
|
265 path)))
|
|
266 (if (consp item) (error "%S is a menu, not a menu item" path))
|
|
267 (aset item 2 t)
|
|
268 (set-menubar-dirty-flag)
|
|
269 item))
|
|
270
|
|
271
|
|
272 (defun add-menu-item-1 (item-p menu-path item-name item-data enabled-p before)
|
|
273 (if before (setq before (downcase before)))
|
|
274 (let* ((menubar current-menubar)
|
|
275 (menu (condition-case ()
|
|
276 (car (find-menu-item menubar menu-path))
|
|
277 (error nil)))
|
|
278 (item (if (listp menu)
|
|
279 (car (find-menu-item (cdr menu) (list item-name)))
|
|
280 (signal 'error (list "not a submenu" menu-path)))))
|
|
281 (or menu
|
|
282 (let ((rest menu-path)
|
|
283 (so-far menubar))
|
|
284 (while rest
|
|
285 ;;; (setq menu (car (find-menu-item (cdr so-far) (list (car rest)))))
|
|
286 (setq menu
|
|
287 (if (eq so-far menubar)
|
|
288 (car (find-menu-item so-far (list (car rest))))
|
|
289 (car (find-menu-item (cdr so-far) (list (car rest))))))
|
|
290 (or menu
|
|
291 (let ((rest2 so-far))
|
|
292 (while (and (cdr rest2) (car (cdr rest2)))
|
|
293 (setq rest2 (cdr rest2)))
|
|
294 (setcdr rest2
|
|
295 (nconc (list (setq menu (list (car rest))))
|
|
296 (cdr rest2)))))
|
|
297 (setq so-far menu)
|
|
298 (setq rest (cdr rest)))))
|
|
299 (or menu (setq menu menubar))
|
|
300 (if item
|
|
301 nil ; it's already there
|
|
302 (if item-p
|
|
303 (setq item (vector item-name item-data enabled-p))
|
|
304 (setq item (cons item-name item-data)))
|
|
305 ;; if BEFORE is specified, try to add it there.
|
|
306 (if before
|
|
307 (setq before (car (find-menu-item menu (list before)))))
|
|
308 (let ((rest menu)
|
|
309 (added-before nil))
|
|
310 (while rest
|
|
311 (if (eq before (car (cdr rest)))
|
|
312 (progn
|
|
313 (setcdr rest (cons item (cdr rest)))
|
|
314 (setq rest nil added-before t))
|
|
315 (setq rest (cdr rest))))
|
|
316 (if (not added-before)
|
|
317 ;; adding before the first item on the menubar itself is harder
|
|
318 (if (and (eq menu menubar) (eq before (car menu)))
|
|
319 (setq menu (cons item menu)
|
|
320 current-menubar menu)
|
|
321 ;; otherwise, add the item to the end.
|
|
322 (nconc menu (list item))))))
|
|
323 (if item-p
|
|
324 (progn
|
|
325 (aset item 1 item-data)
|
|
326 (aset item 2 (not (null enabled-p))))
|
|
327 (setcar item item-name)
|
|
328 (setcdr item item-data))
|
|
329 (set-menubar-dirty-flag)
|
|
330 item))
|
|
331
|
|
332 (defun add-menu-item (menu-path item-name function enabled-p &optional before)
|
|
333 "Add a menu item to some menu, creating the menu first if necessary.
|
|
334 If the named item exists already, it is changed.
|
|
335 MENU-PATH identifies the menu under which the new menu item should be inserted.
|
|
336 It is a list of strings; for example, (\"File\") names the top-level \"File\"
|
|
337 menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\".
|
|
338 ITEM-NAME is the string naming the menu item to be added.
|
|
339 FUNCTION is the command to invoke when this menu item is selected.
|
|
340 If it is a symbol, then it is invoked with `call-interactively', in the same
|
|
341 way that functions bound to keys are invoked. If it is a list, then the
|
|
342 list is simply evaluated.
|
|
343 ENABLED-P controls whether the item is selectable or not.
|
|
344 BEFORE, if provided, is the name of a menu item before which this item should
|
|
345 be added, if this item is not on the menu already. If the item is already
|
|
346 present, it will not be moved."
|
|
347 (or menu-path (error "must specify a menu path"))
|
|
348 (or item-name (error "must specify an item name"))
|
|
349 (add-menu-item-1 t menu-path item-name function enabled-p before))
|
|
350
|
|
351
|
|
352 (defun delete-menu-item (path)
|
|
353 "Remove the named menu item from the menu hierarchy.
|
|
354 PATH is a list of strings which identify the position of the menu item in
|
|
355 the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\"
|
|
356 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the
|
|
357 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
|
|
358 (let* ((menubar current-menubar)
|
|
359 (pair (find-menu-item menubar path))
|
|
360 (item (car pair))
|
|
361 (menu (or (cdr pair) menubar)))
|
|
362 (if (not item)
|
|
363 nil
|
|
364 ;; the menubar is the only special case, because other menus begin
|
|
365 ;; with their name.
|
|
366 (if (eq menu current-menubar)
|
|
367 (setq current-menubar (delq item menu))
|
|
368 (delq item menu))
|
|
369 (set-menubar-dirty-flag)
|
|
370 item)))
|
|
371
|
|
372
|
|
373 (defun relabel-menu-item (path new-name)
|
|
374 "Change the string of the specified menu item.
|
|
375 PATH is a list of strings which identify the position of the menu item in
|
|
376 the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\"
|
|
377 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the
|
|
378 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\".
|
|
379 NEW-NAME is the string that the menu item will be printed as from now on."
|
|
380 (or (stringp new-name)
|
|
381 (setq new-name (signal 'wrong-type-argument (list 'stringp new-name))))
|
|
382 (let* ((menubar current-menubar)
|
|
383 (pair (find-menu-item menubar path))
|
|
384 (item (car pair))
|
|
385 (menu (cdr pair)))
|
|
386 (or item
|
|
387 (signal 'error (list (if menu "No such menu item" "No such menu")
|
|
388 path)))
|
|
389 (if (and (consp item)
|
|
390 (stringp (car item)))
|
|
391 (setcar item new-name)
|
|
392 (aset item 0 new-name))
|
|
393 (set-menubar-dirty-flag)
|
|
394 item))
|
|
395
|
|
396 (defun add-menu (menu-path menu-name menu-items &optional before)
|
|
397 "Add a menu to the menubar or one of its submenus.
|
|
398 If the named menu exists already, it is changed.
|
|
399 MENU-PATH identifies the menu under which the new menu should be inserted.
|
|
400 It is a list of strings; for example, (\"File\") names the top-level \"File\"
|
|
401 menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\".
|
|
402 If MENU-PATH is nil, then the menu will be added to the menubar itself.
|
|
403 MENU-NAME is the string naming the menu to be added.
|
|
404 MENU-ITEMS is a list of menu item descriptions.
|
|
405 Each menu item should be a vector of three elements:
|
|
406 - a string, the name of the menu item;
|
|
407 - a symbol naming a command, or a form to evaluate;
|
|
408 - and t or nil, whether this item is selectable.
|
|
409 BEFORE, if provided, is the name of a menu before which this menu should
|
|
410 be added, if this menu is not on its parent already. If the menu is already
|
|
411 present, it will not be moved."
|
|
412 (or menu-name (error "must specify a menu name"))
|
|
413 (or menu-items (error "must specify some menu items"))
|
|
414 (add-menu-item-1 nil menu-path menu-name menu-items t before))
|
|
415
|
|
416
|
|
417
|
|
418 (defvar put-buffer-names-in-file-menu t)
|
|
419
|
|
420 (defun sensitize-file-and-edit-menus-hook ()
|
|
421 "For use as a value of activate-menubar-hook.
|
|
422 This function changes the sensitivity of these File and Edit menu items:
|
|
423
|
|
424 Cut sensitive only when emacs owns the primary X Selection.
|
|
425 Copy sensitive only when emacs owns the primary X Selection.
|
|
426 Clear sensitive only when emacs owns the primary X Selection.
|
|
427 Paste sensitive only when there is an owner for the X Clipboard Selection.
|
|
428 Undo sensitive only when there is undo information.
|
|
429 While in the midst of an undo, this is changed to \"Undo More\".
|
|
430
|
|
431 Kill Buffer has the name of the current buffer appended to it.
|
|
432 Print Buffer has the name of the current buffer appended to it.
|
|
433 Save Buffer has the name of the current buffer appended to it, and is
|
|
434 sensitive only when the current buffer is modified.
|
|
435 Revert Buffer has the name of the current buffer appended to it, and is
|
|
436 sensitive only when the current buffer has a file.
|
|
437 Delete Frame sensitive only when there is more than one visible frame."
|
|
438 ;;
|
|
439 ;; the hair in here to not update the menubar unless something has changed
|
|
440 ;; isn't really necessary (the menubar code is fast enough) but it makes
|
|
441 ;; me feel better (and creates marginally less list garbage.)
|
|
442 (let* ((file-menu (cdr (car (find-menu-item current-menubar '("File")))))
|
|
443 (edit-menu (cdr (car (find-menu-item current-menubar '("Edit")))))
|
|
444 (save (car (find-menu-item file-menu '("Save Buffer"))))
|
|
445 (rvt (car (find-menu-item file-menu '("Revert Buffer"))))
|
|
446 (del (car (find-menu-item file-menu '("Delete Frame"))))
|
|
447 (print (car (find-menu-item file-menu '("Print Buffer"))))
|
|
448 (kill (car (find-menu-item file-menu '("Kill Buffer"))))
|
|
449 (cut (car (find-menu-item edit-menu '("Cut"))))
|
|
450 (copy (car (find-menu-item edit-menu '("Copy"))))
|
|
451 (paste (car (find-menu-item edit-menu '("Paste"))))
|
|
452 (clear (car (find-menu-item edit-menu '("Clear"))))
|
|
453 (undo (or (car (find-menu-item edit-menu '("Undo")))
|
|
454 (car (find-menu-item edit-menu '("Undo More")))))
|
|
455 (name (buffer-name))
|
|
456 (emacs-owns-selection-p (x-selection-owner-p))
|
|
457 (clipboard-exists-p (x-selection-exists-p 'CLIPBOARD))
|
|
458 undo-available undoing-more
|
|
459 (undo-info-available (not (null (and (not (eq t buffer-undo-list))
|
|
460 (if (eq last-command 'undo)
|
|
461 (setq undoing-more
|
|
462 (and (boundp 'pending-undo-list)
|
|
463 pending-undo-list)
|
|
464 buffer-undo-list))))))
|
|
465 undo-name undo-state
|
|
466 (change-p
|
|
467 (or (and cut (not (eq emacs-owns-selection-p (aref cut 2))))
|
|
468 (and copy (not (eq emacs-owns-selection-p (aref copy 2))))
|
|
469 (and clear (not (eq emacs-owns-selection-p (aref clear 2))))
|
|
470 (and paste (not (eq clipboard-exists-p (aref paste 2))))
|
|
471 (and save (not (eq (buffer-modified-p) (aref save 2))))
|
|
472 (and rvt (not (eq (not (not buffer-file-name)) (aref rvt 2))))
|
|
473 (and del (not (eq (null (cdr (visible-frame-list))) (aref del 2))))
|
|
474 )))
|
|
475 (if (not put-buffer-names-in-file-menu)
|
|
476 nil
|
|
477 (if (= (length save) 4) (progn (aset save 3 name) (setq change-p t)))
|
|
478 (if (= (length rvt) 4) (progn (aset rvt 3 name) (setq change-p t)))
|
|
479 (if (= (length print) 4) (progn (aset print 3 name) (setq change-p t)))
|
|
480 (if (= (length kill) 4) (progn (aset kill 3 name) (setq change-p t))))
|
|
481 (if save (aset save 2 (buffer-modified-p)))
|
|
482 (if rvt (aset rvt 2 (not (not buffer-file-name))))
|
|
483 (if del (aset del 2 (null (cdr (visible-frame-list)))))
|
|
484 (if cut (aset cut 2 emacs-owns-selection-p))
|
|
485 (if copy (aset copy 2 emacs-owns-selection-p))
|
|
486 (if clear (aset clear 2 emacs-owns-selection-p))
|
|
487 (if paste (aset paste 2 clipboard-exists-p))
|
|
488
|
|
489 ;; we could also do this with the third field of the item.
|
|
490 (if (eq last-command 'undo)
|
|
491 (setq undo-name "Undo More"
|
|
492 undo-state (not (null (and (boundp 'pending-undo-list)
|
|
493 pending-undo-list))))
|
|
494 (setq undo-name "Undo"
|
|
495 undo-state (and (not (eq buffer-undo-list t))
|
|
496 (not (null
|
|
497 (or buffer-undo-list
|
|
498 (and (boundp 'pending-undo-list)
|
|
499 pending-undo-list)))))))
|
|
500 (if buffer-read-only (setq undo-state nil))
|
|
501 (if (and undo
|
|
502 (or (not (equal undo-name (aref undo 0)))
|
|
503 (not (eq undo-state (aref undo 2)))))
|
|
504 (progn (aset undo 0 undo-name)
|
|
505 (aset undo 2 undo-state)
|
|
506 (setq change-p t)))
|
|
507 ;; if we made any changes, return nil
|
|
508 ;; otherwise return t to indicate that we haven't done anything.
|
|
509 (not change-p)))
|
|
510
|
|
511 ;; this version is too slow
|
|
512 (defun format-buffers-menu-line (buffer)
|
|
513 "Returns a string to represent the given buffer in the Buffer menu.
|
|
514 nil means the buffer shouldn't be listed. You can redefine this."
|
|
515 (if (string-match "\\` " (buffer-name buffer))
|
|
516 nil
|
|
517 (save-excursion
|
|
518 (set-buffer buffer)
|
|
519 (let ((size (buffer-size)))
|
|
520 (format "%s%s %-19s %6s %-15s %s"
|
|
521 (if (buffer-modified-p) "*" " ")
|
|
522 (if buffer-read-only "%" " ")
|
|
523 (buffer-name)
|
|
524 size
|
|
525 mode-name
|
|
526 (or (buffer-file-name) ""))))))
|
|
527
|
|
528 (defun format-buffers-menu-line (buffer)
|
|
529 (if (string-match "\\` " (setq buffer (buffer-name buffer)))
|
|
530 nil
|
|
531 buffer))
|
|
532
|
|
533 (defvar buffers-menu-max-size 10
|
|
534 "*Maximum number of entries which may appear on the \"Buffers\" menu.
|
|
535 If this is 10, then only the ten most-recently-selected buffers will be
|
|
536 shown. If this is nil, then all buffers will be shown. Setting this to
|
|
537 a large number or nil will slow down menu responsiveness.")
|
|
538
|
|
539 (defvar complex-buffers-menu-p nil
|
|
540 "*If true, the buffers menu will contain several commands, as submenus
|
|
541 of each buffer line. If this is false, then there will be only one command:
|
|
542 select that buffer.")
|
|
543
|
|
544 (defvar buffers-menu-switch-to-buffer-function 'switch-to-buffer
|
|
545 "*The function to call to select a buffer from the buffers menu.
|
|
546 `switch-to-buffer' is a good choice, as is `pop-to-buffer'.")
|
|
547
|
|
548
|
|
549 (defun buffer-menu-save-buffer (buffer)
|
|
550 (save-excursion
|
|
551 (set-buffer buffer)
|
|
552 (save-buffer)))
|
|
553
|
|
554 (defun buffer-menu-write-file (buffer)
|
|
555 (save-excursion
|
|
556 (set-buffer buffer)
|
|
557 (write-file (read-file-name
|
|
558 (concat "Write " (buffer-name (current-buffer))
|
|
559 " to file: ")))))
|
|
560
|
|
561
|
|
562 (defsubst build-buffers-menu-internal (buffers)
|
|
563 (let (name line)
|
|
564 (mapcar
|
|
565 (if complex-buffers-menu-p
|
|
566 (function
|
|
567 (lambda (buffer)
|
|
568 (if (setq line (format-buffers-menu-line buffer))
|
|
569 (list line
|
|
570 (vector "Switch to Buffer"
|
|
571 (list buffers-menu-switch-to-buffer-function
|
|
572 (setq name (buffer-name buffer)))
|
|
573 t)
|
|
574 (if (and (buffer-modified-p buffer)
|
|
575 (buffer-file-name buffer))
|
|
576 (vector "Save Buffer"
|
|
577 (list 'buffer-menu-save-buffer name) t)
|
|
578 ["Save Buffer" nil nil])
|
|
579 (vector "Save Buffer As..."
|
|
580 (list 'buffer-menu-write-file name) t)
|
|
581 (vector "Kill Buffer" (list 'kill-buffer name) t)))))
|
|
582 (function (lambda (buffer)
|
|
583 (if (setq line (format-buffers-menu-line buffer))
|
|
584 (vector line
|
|
585 (list buffers-menu-switch-to-buffer-function
|
|
586 (buffer-name buffer))
|
|
587 t)))))
|
|
588 buffers)))
|
|
589
|
|
590 (defun build-buffers-menu-hook ()
|
|
591 "For use as a value of activate-menubar-hook.
|
|
592 This function changes the contents of the \"Buffers\" menu to correspond
|
|
593 to the current set of buffers. Only the most-recently-used few buffers
|
|
594 will be listed on the menu, for efficiency reasons. You can control how
|
|
595 many buffers will be shown by setting `buffers-menu-max-size'.
|
|
596 You can control the text of the menu items by redefining the function
|
|
597 `format-buffers-menu-line'."
|
|
598 (let ((buffer-menu (car (find-menu-item current-menubar '("Buffers"))))
|
|
599 name
|
|
600 buffers)
|
|
601 (if (not buffer-menu)
|
|
602 nil
|
|
603 (setq buffers (buffer-list))
|
|
604
|
|
605 (if (and (integerp buffers-menu-max-size)
|
|
606 (> buffers-menu-max-size 1))
|
|
607 (if (> (length buffers) buffers-menu-max-size)
|
|
608 (setcdr (nthcdr buffers-menu-max-size buffers) nil)))
|
|
609
|
|
610 (setq buffers (build-buffers-menu-internal buffers))
|
|
611 (setq buffers (nconc (delq nil buffers)
|
|
612 '("----" ["List All Buffers" list-buffers t])))
|
|
613 ;; slightly (only slightly) more efficient to not install the menubar
|
|
614 ;; if it hasn't visibly changed.
|
|
615 (if (equal buffers (cdr buffer-menu))
|
|
616 t ; return t meaning "no change"
|
|
617 (setcdr buffer-menu buffers)
|
|
618 (set-menubar-dirty-flag)
|
|
619 nil))))
|
|
620
|
|
621 (add-hook 'activate-menubar-hook 'build-buffers-menu-hook)
|
|
622 (add-hook 'activate-menubar-hook 'sensitize-file-and-edit-menus-hook)
|
|
623
|
|
624 (let ((frames (frame-list)))
|
|
625 (while frames
|
|
626 (modify-frame-parameters (car frames) '((menu-bar-lines . 1)))
|
|
627 (setq frames (cdr frames))))
|
|
628 (or (assq 'menu-bar-lines default-frame-alist)
|
|
629 (setq default-frame-alist
|
|
630 (cons '(menu-bar-lines . 1) default-frame-alist)))
|
|
631
|
|
632 (set-menubar default-menubar)
|
|
633
|
|
634 (provide 'menubar)
|
|
635
|