Commit | Line | Data |
---|---|---|
c7986c18 ER |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
634 | (provide 'menubar) | |
635 |