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