X-Git-Url: http://git.chise.org/gitweb/?p=chise%2Fxemacs-chise.git.1;a=blobdiff_plain;f=lisp%2Fmenubar.el;h=b26065c44c2bc42e27fc432621d7904b447294bd;hp=3b58c86f23f025f31cca71d1f7dd2305489093e4;hb=566b3d194e2d5c783808ac39437bd7e1a28b1c5c;hpb=2fd9701a4f902054649dde9143a3f77809afee8f diff --git a/lisp/menubar.el b/lisp/menubar.el index 3b58c86..b26065c 100644 --- a/lisp/menubar.el +++ b/lisp/menubar.el @@ -20,7 +20,7 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the +;; along with XEmacs; see the file COPYING. If not, write to the ;; Free Software Foundation, 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. @@ -30,7 +30,7 @@ ;; This file is dumped with XEmacs (when menubar support is compiled in). -;; Some stuff in FSF menu-bar.el is in x-menubar.el +;; Some stuff in FSF menu-bar.el is in menubar-items.el ;;; Code: @@ -96,7 +96,7 @@ See `current-menubar' for a description of the syntax of a menubar." ((stringp menuitem) (and (string-match "^\\(-+\\|=+\\):\\(.*\\)" menuitem) (setq item (match-string 2 menuitem)) - (or (member item '(;; Motif-compatible + (or (member item '(;; Motif-compatible "singleLine" "doubleLine" "singleDashedLine" @@ -289,14 +289,13 @@ MENU-LEAF is a menubar leaf node. See the documentation of `current-menubar'. BEFORE, if provided, is the name of a menu item before which this item should be added, if this item is not on the menu already. If the item is already present, it will not be moved. -If IN-MENU is present use that instead of `current-menubar' as the menu to -change. -" +IN-MENU, if provided, means use that instead of `current-menubar' as the + menu to change." ;; Note easymenu.el uses the fact that menu-leaf can be a submenu. (add-menu-item-1 t menu-path menu-leaf before in-menu)) ;; I actually liked the old name better, but the interface has changed too -;; drastically to keep it. --Stig +;; drastically to keep it. --Stig (defun add-submenu (menu-path submenu &optional before in-menu) "Add a menu to the menubar or one of its submenus. If the named menu exists already, it is changed. @@ -308,33 +307,38 @@ SUBMENU is the new menu to add. See the documentation of `current-menubar' for the syntax. BEFORE, if provided, is the name of a menu before which this menu should be added, if this menu is not on its parent already. If the menu is already - present, it will not be moved." + present, it will not be moved. +IN-MENU, if provided, means use that instead of `current-menubar' as the + menu to change." (check-menu-syntax submenu nil) (add-menu-item-1 nil menu-path submenu before in-menu)) - -(defun purecopy-menubar (x) - ;; this calls purecopy on the strings, and the contents of the vectors, - ;; but not on the vectors themselves, or the conses - those must be - ;; writable. - (cond ((vectorp x) - (let ((i (length x))) - (while (> i 0) - (aset x (1- i) (purecopy (aref x (1- i)))) - (setq i (1- i)))) - x) - ((consp x) - (let ((rest x)) - (while rest - (setcar rest (purecopy-menubar (car rest))) - (setq rest (cdr rest)))) - x) - (t - (purecopy x)))) +;; purespace is no more, so this function is unnecessary +;(defun purecopy-menubar (x) +; ;; this calls purecopy on the strings, and the contents of the vectors, +; ;; but not on the vectors themselves, or the conses - those must be +; ;; writable. +; (cond ((vectorp x) +; (let ((i (length x))) +; (while (> i 0) +; (aset x (1- i) (purecopy (aref x (1- i)))) +; (setq i (1- i)))) +; x) +; ((consp x) +; (let ((rest x)) +; (while rest +; (setcar rest (purecopy-menubar (car rest))) +; (setq rest (cdr rest)))) +; x) +; (t +; (purecopy x)))) (defun delete-menu-item (path &optional from-menu) "Remove the named menu item from the menu hierarchy. -PATH is a list of strings which identify the position of the menu item in -the menu hierarchy. The documentation of `add-submenu' describes menu-paths." +PATH is a list of strings which identify the position of the menu item +in the menu hierarchy. The documentation of `add-submenu' describes +menu paths. +FROM-MENU, if provided, means use that instead of `current-menubar' +as the menu to change." (let* ((pair (condition-case nil (find-menu-item (or from-menu current-menubar) path) (error nil))) @@ -352,13 +356,12 @@ the menu hierarchy. The documentation of `add-submenu' describes menu-paths." (defun relabel-menu-item (path new-name) "Change the string of the specified menu item. -PATH is a list of strings which identify the position of the menu item in +PATH is a list of strings which identify the position of the menu item in the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the +under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the menu item called \"Item\" under the \"Foo\" submenu of \"Menu\". NEW-NAME is the string that the menu item will be printed as from now on." - (or (stringp new-name) - (setq new-name (signal 'wrong-type-argument (list 'stringp new-name)))) + (check-type new-name string) (let* ((menubar current-menubar) (pair (find-menu-item menubar path)) (item (car pair)) @@ -380,7 +383,7 @@ NEW-NAME is the string that the menu item will be printed as from now on." ;; into the menubar if we didn't want people to use 'em? ;; x-font-menu.el is the only known offender right now and that ought to be ;; rehashed a bit. -;; +;; (defun enable-menu-item-1 (path toggle-p on-p) (let (menu item) @@ -430,37 +433,235 @@ NEW-NAME is the string that the menu item will be printed as from now on." (defun enable-menu-item (path) "Make the named menu item be selectable. -PATH is a list of strings which identify the position of the menu item in +PATH is a list of strings which identify the position of the menu item in the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the +under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." (enable-menu-item-1 path nil t)) (defun disable-menu-item (path) "Make the named menu item be unselectable. -PATH is a list of strings which identify the position of the menu item in +PATH is a list of strings which identify the position of the menu item in the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the +under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." (enable-menu-item-1 path nil nil)) (defun select-toggle-menu-item (path) "Make the named toggle- or radio-style menu item be in the `selected' state. -PATH is a list of strings which identify the position of the menu item in +PATH is a list of strings which identify the position of the menu item in the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the +under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." (enable-menu-item-1 path t t)) (defun deselect-toggle-menu-item (path) "Make the named toggle- or radio-style menu item be in the `unselected' state. -PATH is a list of strings which identify the position of the menu item in +PATH is a list of strings which identify the position of the menu item in the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the +under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." (enable-menu-item-1 path t nil)) + +;;;;;;; popup menus + +(defvar global-popup-menu nil + "The global popup menu. This is present in all modes. +See the function `popup-menu' for a description of menu syntax.") + +(defvar mode-popup-menu nil + "The mode-specific popup menu. Automatically buffer local. +This is appended to the default items in `global-popup-menu'. +See the function `popup-menu' for a description of menu syntax.") +(make-variable-buffer-local 'mode-popup-menu) + +(defvar activate-popup-menu-hook nil + "Function or functions run before a mode-specific popup menu is made visible. +These functions are called with no arguments, and should interrogate and +modify the value of `global-popup-menu' or `mode-popup-menu' as desired. +Note: this hook is only run if you use `popup-mode-menu' for activating the +global and mode-specific commands; if you have your own binding for button3, +this hook won't be run.") + +(defvar last-popup-menu-event nil + "The mouse event that invoked the last popup menu. +NOTE: This is EXPERIMENTAL and may change at any time.") + +(defun popup-mode-menu (&optional event) + "Pop up a menu of global and mode-specific commands. +The menu is computed by combining `global-popup-menu' and `mode-popup-menu' +with any items derived from the `context-menu' property of the extent where the +button was clicked." + (interactive "_e") + (setq last-popup-menu-event + (or (and event (button-event-p event) event) + (let* ((mouse-pos (mouse-position)) + (win (car mouse-pos)) + (x (cadr mouse-pos)) + (y (cddr mouse-pos)) + (edges (window-pixel-edges win)) + (winx (first edges)) + (winy (second edges)) + (x (+ x winx)) + (y (+ y winy))) + (make-event 'button-press + `(button 3 x ,x y ,y channel ,(window-frame win) + timestamp ,(current-event-timestamp + (cdfw-console win))))))) + (run-hooks 'activate-popup-menu-hook) + (let* ((context-window (and event (event-window event))) + (context-point (and event (event-point event))) + (context-extents (and context-window + context-point + (extents-at context-point + (window-buffer context-window) + 'context-menu))) + (context-menu-items + (apply 'append (mapcar #'(lambda (extent) + (extent-property extent 'context-menu)) + context-extents)))) + (popup-menu + (progn + ;; Merge global-popup-menu and mode-popup-menu + (and mode-popup-menu (check-menu-syntax mode-popup-menu)) + (let* ((mode-title (and (stringp (car mode-popup-menu)) + (car mode-popup-menu))) + (mode-items (if mode-title (cdr mode-popup-menu) + mode-popup-menu)) + (global-title (and (stringp (car global-popup-menu)) + (car global-popup-menu))) + (global-items (if global-title (cdr global-popup-menu) + global-popup-menu)) + mode-filters) + ;; Strip keywords from local menu for attaching them at the top + (while (and mode-items + (keywordp (car mode-items))) + ;; Push both keyword and its argument. + (push (pop mode-items) mode-filters) + (push (pop mode-items) mode-filters)) + (setq mode-filters (nreverse mode-filters)) + ;; If mode-filters contains a keyword already present in + ;; `global-popup-menu', you will probably lose. + (append (cond ((not popup-menu-titles) (list "")) + (mode-title (list mode-title)) + (global-title (list global-title)) + (t (list ""))) + mode-filters + context-menu-items + (and context-menu-items mode-items '("---")) + mode-items + (and (or context-menu-items mode-items) + global-items '("---" "---")) + (and global-title (list global-title)) + global-items + )))) + + (while (popup-up-p) + (dispatch-event (next-event))) + + )) + +(defun popup-buffer-menu (event) + "Pop up a copy of the Buffers menu (from the menubar) where the mouse is clicked." + (interactive "e") + (let ((window (and (event-over-text-area-p event) (event-window event))) + (bmenu nil)) + (or window + (error "Pointer must be in a normal window")) + (select-window window) + (if current-menubar + (setq bmenu (assoc "%_Buffers" current-menubar))) + (if (null bmenu) + (setq bmenu (assoc "%_Buffers" default-menubar))) + (if (null bmenu) + (error "Can't find the Buffers menu")) + (popup-menu bmenu))) + +(defun popup-menubar-menu (event) + "Pop up a copy of menu that also appears in the menubar." + (interactive "e") + (let ((window (and (event-over-text-area-p event) (event-window event))) + popup-menubar) + (or window + (error "Pointer must be in a normal window")) + (select-window window) + (and current-menubar (run-hooks 'activate-menubar-hook)) + ;; #### Instead of having to copy this just to safely get rid of + ;; any nil what we should really do is fix up the internal menubar + ;; code to just ignore nil if generating a popup menu + (setq popup-menubar (delete nil (copy-sequence (or current-menubar + default-menubar)))) + (popup-menu (cons "%_Menubar Menu" popup-menubar)) + )) + +(defun menu-call-at-event (form &optional event default-behavior-fallback) + "Call FORM while temporarily setting point to the position in EVENT. +NOTE: This is EXPERIMENTAL and may change at any time. + +FORM is called the way forms in menu specs are: i.e. if a symbol, it's called +with `call-interactively', otherwise with `eval'. EVENT defaults to +`last-popup-menu-event', making this function especially useful in popup +menus. The buffer and point are set temporarily within a `save-excursion'. +If EVENT is not a mouse event, or was not over a buffer, nothing +happens unless DEFAULT-BEHAVIOR-FALLBACK is non-nil, in which case the +FORM is called normally." + (or event (setq event last-popup-menu-event)) + (let ((buf (event-buffer event)) + (p (event-closest-point event))) + (cond ((and buf p (> p 0)) + (save-excursion + (set-buffer buf) + (goto-char p) + (if (symbolp form) + (call-interactively form) + (eval form)))) + (default-behavior-fallback + (if (symbolp form) + (call-interactively form) + (eval form)))))) + +(global-set-key 'button3 'popup-mode-menu) +;; shift button3 and shift button2 are reserved for Hyperbole +(global-set-key '(meta control button3) 'popup-buffer-menu) +;; The following command is way too dangerous with Custom. +;; (global-set-key '(meta shift button3) 'popup-menubar-menu) + +;; Here's a test of the cool new menu features (from Stig). + +;;(setq mode-popup-menu +;; '("Test Popup Menu" +;; :filter cdr +;; ["this item won't appear because of the menu filter" ding t] +;; "--:singleLine" +;; "singleLine" +;; "--:doubleLine" +;; "doubleLine" +;; "--:singleDashedLine" +;; "singleDashedLine" +;; "--:doubleDashedLine" +;; "doubleDashedLine" +;; "--:noLine" +;; "noLine" +;; "--:shadowEtchedIn" +;; "shadowEtchedIn" +;; "--:shadowEtchedOut" +;; "shadowEtchedOut" +;; "--:shadowDoubleEtchedIn" +;; "shadowDoubleEtchedIn" +;; "--:shadowDoubleEtchedOut" +;; "shadowDoubleEtchedOut" +;; "--:shadowEtchedInDash" +;; "shadowEtchedInDash" +;; "--:shadowEtchedOutDash" +;; "shadowEtchedOutDash" +;; "--:shadowDoubleEtchedInDash" +;; "shadowDoubleEtchedInDash" +;; "--:shadowDoubleEtchedOutDash" +;; "shadowDoubleEtchedOutDash" +;; )) + (defun get-popup-menu-response (menu-desc &optional event) "Pop up the given menu and wait for a response. This blocks until the response is received, and returns the misc-user @@ -470,6 +671,10 @@ If no response was received, nil is returned. MENU-DESC and EVENT are as in the call to `popup-menu'." ;; partially stolen from w3 + + ;; This function is way gross and assumes to much about menu + ;; processing that is X specific. Under mswindows popup menus behave + ;; in reasonable ways that you can't obstruct. (let ((echo-keystrokes 0) new-event) (popup-menu menu-desc event) @@ -478,14 +683,22 @@ MENU-DESC and EVENT are as in the call to `popup-menu'." (setq new-event (next-command-event new-event)) (cond ((misc-user-event-p new-event) (throw 'popup-done new-event)) - ((not (popup-up-p)) - (setq unread-command-events (cons new-event - unread-command-events)) - (throw 'popup-done nil)) ((button-release-event-p new-event);; don't beep twice nil) - ((event-matches-key-specifier-p (quit-char)) + ;; It shows how bogus this function is that the event + ;; arg could be missing and no-one noticed ... + ((event-matches-key-specifier-p new-event (quit-char)) (signal 'quit nil)) + ;; mswindows has no pop-down processing (selection is + ;; atomic) so doing anything more makes no sense. Since + ;; popup-up-p is always false under mswindows, this + ;; function has been ordered to do essentially X-specifc + ;; processing after this check. + ((not (popup-up-p)) + (setq unread-command-events (cons new-event + unread-command-events)) + (throw 'popup-done nil)) + ;; mswindows never gets here (t (beep) (message "please make a choice from the menu.")))))))