Mercurial > hg > xemacs-beta

comparison lisp/menubar.el @ 444:576fb035e263 r21-2-37

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-37
author cvs
date Mon, 13 Aug 2007 11:36:19 +0200
parents abe6d1db359e
children 1ccc32a20af4
comparison
equal deleted inserted replaced
443:a8296e22da4e 444:576fb035e263
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of 18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 ;; General Public License for more details. 20 ;; General Public License for more details.
21 21
22 ;; You should have received a copy of the GNU General Public License 22 ;; You should have received a copy of the GNU General Public License
23 ;; along with XEmacs; see the file COPYING. If not, write to the 23 ;; along with XEmacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, 59 Temple Place - Suite 330, 24 ;; Free Software Foundation, 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA. 25 ;; Boston, MA 02111-1307, USA.
26 26
27 ;;; Synched up with: Not in FSF. (Completely divergent from FSF menu-bar.el) 27 ;;; Synched up with: Not in FSF. (Completely divergent from FSF menu-bar.el)
28 28
94 (setq menuitem (car menu)) 94 (setq menuitem (car menu))
95 (cond 95 (cond
96 ((stringp menuitem) 96 ((stringp menuitem)
97 (and (string-match "^\\(-+\\|=+\\):\\(.*\\)" menuitem) 97 (and (string-match "^\\(-+\\|=+\\):\\(.*\\)" menuitem)
98 (setq item (match-string 2 menuitem)) 98 (setq item (match-string 2 menuitem))
99 (or (member item '(;; Motif-compatible 99 (or (member item '(;; Motif-compatible
100 "singleLine" 100 "singleLine"
101 "doubleLine" 101 "doubleLine"
102 "singleDashedLine" 102 "singleDashedLine"
103 "doubleDashedLine" 103 "doubleDashedLine"
104 "noLine" 104 "noLine"
287 menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". 287 menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\".
288 MENU-LEAF is a menubar leaf node. See the documentation of `current-menubar'. 288 MENU-LEAF is a menubar leaf node. See the documentation of `current-menubar'.
289 BEFORE, if provided, is the name of a menu item before which this item should 289 BEFORE, if provided, is the name of a menu item before which this item should
290 be added, if this item is not on the menu already. If the item is already 290 be added, if this item is not on the menu already. If the item is already
291 present, it will not be moved. 291 present, it will not be moved.
292 If IN-MENU is present use that instead of `current-menubar' as the menu to 292 IN-MENU, if provided, means use that instead of `current-menubar' as the
293 change. 293 menu to change."
294 "
295 ;; Note easymenu.el uses the fact that menu-leaf can be a submenu. 294 ;; Note easymenu.el uses the fact that menu-leaf can be a submenu.
296 (add-menu-item-1 t menu-path menu-leaf before in-menu)) 295 (add-menu-item-1 t menu-path menu-leaf before in-menu))
297 296
298 ;; I actually liked the old name better, but the interface has changed too 297 ;; I actually liked the old name better, but the interface has changed too
299 ;; drastically to keep it. --Stig 298 ;; drastically to keep it. --Stig
300 (defun add-submenu (menu-path submenu &optional before in-menu) 299 (defun add-submenu (menu-path submenu &optional before in-menu)
301 "Add a menu to the menubar or one of its submenus. 300 "Add a menu to the menubar or one of its submenus.
302 If the named menu exists already, it is changed. 301 If the named menu exists already, it is changed.
303 MENU-PATH identifies the menu under which the new menu should be inserted. 302 MENU-PATH identifies the menu under which the new menu should be inserted.
304 It is a list of strings; for example, (\"File\") names the top-level \"File\" 303 It is a list of strings; for example, (\"File\") names the top-level \"File\"
306 If MENU-PATH is nil, then the menu will be added to the menubar itself. 305 If MENU-PATH is nil, then the menu will be added to the menubar itself.
307 SUBMENU is the new menu to add. 306 SUBMENU is the new menu to add.
308 See the documentation of `current-menubar' for the syntax. 307 See the documentation of `current-menubar' for the syntax.
309 BEFORE, if provided, is the name of a menu before which this menu should 308 BEFORE, if provided, is the name of a menu before which this menu should
310 be added, if this menu is not on its parent already. If the menu is already 309 be added, if this menu is not on its parent already. If the menu is already
311 present, it will not be moved." 310 present, it will not be moved.
311 IN-MENU, if provided, means use that instead of `current-menubar' as the
312 menu to change."
312 (check-menu-syntax submenu nil) 313 (check-menu-syntax submenu nil)
313 (add-menu-item-1 nil menu-path submenu before in-menu)) 314 (add-menu-item-1 nil menu-path submenu before in-menu))
314 315 ;; purespace is no more, so this function is unnecessary
315 (defun purecopy-menubar (x) 316 ;(defun purecopy-menubar (x)
316 ;; this calls purecopy on the strings, and the contents of the vectors, 317 ; ;; this calls purecopy on the strings, and the contents of the vectors,
317 ;; but not on the vectors themselves, or the conses - those must be 318 ; ;; but not on the vectors themselves, or the conses - those must be
318 ;; writable. 319 ; ;; writable.
319 (cond ((vectorp x) 320 ; (cond ((vectorp x)
320 (let ((i (length x))) 321 ; (let ((i (length x)))
321 (while (> i 0) 322 ; (while (> i 0)
322 (aset x (1- i) (purecopy (aref x (1- i)))) 323 ; (aset x (1- i) (purecopy (aref x (1- i))))
323 (setq i (1- i)))) 324 ; (setq i (1- i))))
324 x) 325 ; x)
325 ((consp x) 326 ; ((consp x)
326 (let ((rest x)) 327 ; (let ((rest x))
327 (while rest 328 ; (while rest
328 (setcar rest (purecopy-menubar (car rest))) 329 ; (setcar rest (purecopy-menubar (car rest)))
329 (setq rest (cdr rest)))) 330 ; (setq rest (cdr rest))))
330 x) 331 ; x)
331 (t 332 ; (t
332 (purecopy x)))) 333 ; (purecopy x))))
333 334
334 (defun delete-menu-item (path &optional from-menu) 335 (defun delete-menu-item (path &optional from-menu)
335 "Remove the named menu item from the menu hierarchy. 336 "Remove the named menu item from the menu hierarchy.
336 PATH is a list of strings which identify the position of the menu item in 337 PATH is a list of strings which identify the position of the menu item
337 the menu hierarchy. The documentation of `add-submenu' describes menu-paths." 338 in the menu hierarchy. The documentation of `add-submenu' describes
339 menu paths.
340 FROM-MENU, if provided, means use that instead of `current-menubar'
341 as the menu to change."
338 (let* ((pair (condition-case nil (find-menu-item (or from-menu 342 (let* ((pair (condition-case nil (find-menu-item (or from-menu
339 current-menubar) path) 343 current-menubar) path)
340 (error nil))) 344 (error nil)))
341 (item (car pair)) 345 (item (car pair))
342 (parent (or (cdr pair) current-menubar))) 346 (parent (or (cdr pair) current-menubar)))
350 (set-menubar-dirty-flag) 354 (set-menubar-dirty-flag)
351 item))) 355 item)))
352 356
353 (defun relabel-menu-item (path new-name) 357 (defun relabel-menu-item (path new-name)
354 "Change the string of the specified menu item. 358 "Change the string of the specified menu item.
355 PATH is a list of strings which identify the position of the menu item in 359 PATH is a list of strings which identify the position of the menu item in
356 the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" 360 the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\"
357 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the 361 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the
358 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\". 362 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\".
359 NEW-NAME is the string that the menu item will be printed as from now on." 363 NEW-NAME is the string that the menu item will be printed as from now on."
360 (or (stringp new-name) 364 (or (stringp new-name)
361 (setq new-name (signal 'wrong-type-argument (list 'stringp new-name)))) 365 (setq new-name (wrong-type-argument 'stringp new-name)))
362 (let* ((menubar current-menubar) 366 (let* ((menubar current-menubar)
363 (pair (find-menu-item menubar path)) 367 (pair (find-menu-item menubar path))
364 (item (car pair)) 368 (item (car pair))
365 (menu (cdr pair))) 369 (menu (cdr pair)))
366 (or item 370 (or item
378 ;; 382 ;;
379 ;; these are all bad style. Why in the world would we put evaluable forms 383 ;; these are all bad style. Why in the world would we put evaluable forms
380 ;; into the menubar if we didn't want people to use 'em? 384 ;; into the menubar if we didn't want people to use 'em?
381 ;; x-font-menu.el is the only known offender right now and that ought to be 385 ;; x-font-menu.el is the only known offender right now and that ought to be
382 ;; rehashed a bit. 386 ;; rehashed a bit.
383 ;; 387 ;;
384 388
385 (defun enable-menu-item-1 (path toggle-p on-p) 389 (defun enable-menu-item-1 (path toggle-p on-p)
386 (let (menu item) 390 (let (menu item)
387 (if (and (vectorp path) (> (length path) 2)) ; limited syntax checking... 391 (if (and (vectorp path) (> (length path) 2)) ; limited syntax checking...
388 (setq item path) 392 (setq item path)
428 (set-menubar-dirty-flag) 432 (set-menubar-dirty-flag)
429 item)) 433 item))
430 434
431 (defun enable-menu-item (path) 435 (defun enable-menu-item (path)
432 "Make the named menu item be selectable. 436 "Make the named menu item be selectable.
433 PATH is a list of strings which identify the position of the menu item in 437 PATH is a list of strings which identify the position of the menu item in
434 the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" 438 the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\"
435 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the 439 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the
436 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." 440 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
437 (enable-menu-item-1 path nil t)) 441 (enable-menu-item-1 path nil t))
438 442
439 (defun disable-menu-item (path) 443 (defun disable-menu-item (path)
440 "Make the named menu item be unselectable. 444 "Make the named menu item be unselectable.
441 PATH is a list of strings which identify the position of the menu item in 445 PATH is a list of strings which identify the position of the menu item in
442 the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" 446 the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\"
443 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the 447 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the
444 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." 448 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
445 (enable-menu-item-1 path nil nil)) 449 (enable-menu-item-1 path nil nil))
446 450
447 (defun select-toggle-menu-item (path) 451 (defun select-toggle-menu-item (path)
448 "Make the named toggle- or radio-style menu item be in the `selected' state. 452 "Make the named toggle- or radio-style menu item be in the `selected' state.
449 PATH is a list of strings which identify the position of the menu item in 453 PATH is a list of strings which identify the position of the menu item in
450 the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" 454 the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\"
451 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the 455 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the
452 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." 456 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
453 (enable-menu-item-1 path t t)) 457 (enable-menu-item-1 path t t))
454 458
455 (defun deselect-toggle-menu-item (path) 459 (defun deselect-toggle-menu-item (path)
456 "Make the named toggle- or radio-style menu item be in the `unselected' state. 460 "Make the named toggle- or radio-style menu item be in the `unselected' state.
457 PATH is a list of strings which identify the position of the menu item in 461 PATH is a list of strings which identify the position of the menu item in
458 the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" 462 the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\"
459 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the 463 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the
460 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." 464 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
461 (enable-menu-item-1 path t nil)) 465 (enable-menu-item-1 path t nil))
462 466
463 467
464 468
552 556
553 (while (popup-up-p) 557 (while (popup-up-p)
554 (dispatch-event (next-event))) 558 (dispatch-event (next-event)))
555 559
556 )) 560 ))
557 561
558 (defun popup-buffer-menu (event) 562 (defun popup-buffer-menu (event)
559 "Pop up a copy of the Buffers menu (from the menubar) where the mouse is clicked." 563 "Pop up a copy of the Buffers menu (from the menubar) where the mouse is clicked."
560 (interactive "e") 564 (interactive "e")
561 (let ((window (and (event-over-text-area-p event) (event-window event))) 565 (let ((window (and (event-over-text-area-p event) (event-window event)))
562 (bmenu nil)) 566 (bmenu nil))