;; 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.
;; 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:
((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"
menuitem)))
(setq plistp (or (>= L 5)
(and (> L 2) (keywordp (aref menuitem 2)))))
- (or (stringp (aref menuitem 0))
- (signal 'error
- (list
- "first element of a button must be a string (the label)"
- menuitem)))
- (or plistp
- (< L 4)
- (null (aref menuitem 3))
- (stringp (aref menuitem 3))
- (signal 'error
- (list
- "fourth element of a button must be a string (the label suffix)"
- menuitem)))
(if plistp
(let ((i 2)
selp
menuitem)))
)))
)
- ;; (t (signal 'error (list "unrecognised menu descriptor" menuitem))))
- (t (message "unrecognised menu descriptor %s" (prin1-to-string menuitem))))
+ ;; (t (signal 'error (list "unrecognized menu descriptor" menuitem))))
+ (t (message "unrecognized menu descriptor %s" (prin1-to-string menuitem))))
(setq menu (cdr menu)))))
\f
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.
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)))
(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))
;; 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)
(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))
\f
+
+;;;;;;; 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
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)
(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.")))))))
projects / chise / xemacs-chise.git.1 / blobdiff