Mercurial > hg > xemacs-beta

comparison lisp/menubar.el @ 442:abe6d1db359e r21-2-36

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-36
author cvs
date Mon, 13 Aug 2007 11:35:02 +0200
parents 3ecd8885ac67
children 576fb035e263
comparison
equal deleted inserted replaced
441:72a7cfa4a488 442:abe6d1db359e
28 28
29 ;;; Commentary: 29 ;;; Commentary:
30 30
31 ;; This file is dumped with XEmacs (when menubar support is compiled in). 31 ;; This file is dumped with XEmacs (when menubar support is compiled in).
32 32
33 ;; Some stuff in FSF menu-bar.el is in x-menubar.el 33 ;; Some stuff in FSF menu-bar.el is in menubar-items.el
34 34
35 ;;; Code: 35 ;;; Code:
36 36
37 (defgroup menu nil 37 (defgroup menu nil
38 "Input from the menus." 38 "Input from the menus."
126 (signal 'error 126 (signal 'error
127 (list "button descriptors must be at least 2 long" 127 (list "button descriptors must be at least 2 long"
128 menuitem))) 128 menuitem)))
129 (setq plistp (or (>= L 5) 129 (setq plistp (or (>= L 5)
130 (and (> L 2) (keywordp (aref menuitem 2))))) 130 (and (> L 2) (keywordp (aref menuitem 2)))))
131 (or (stringp (aref menuitem 0))
132 (signal 'error
133 (list
134 "first element of a button must be a string (the label)"
135 menuitem)))
136 (or plistp
137 (< L 4)
138 (null (aref menuitem 3))
139 (stringp (aref menuitem 3))
140 (signal 'error
141 (list
142 "fourth element of a button must be a string (the label suffix)"
143 menuitem)))
144 (if plistp 131 (if plistp
145 (let ((i 2) 132 (let ((i 2)
146 selp 133 selp
147 style 134 style
148 item) 135 item)
472 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the 459 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the
473 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." 460 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
474 (enable-menu-item-1 path t nil)) 461 (enable-menu-item-1 path t nil))
475 462
476 463
464
465 ;;;;;;; popup menus
466
467 (defvar global-popup-menu nil
468 "The global popup menu. This is present in all modes.
469 See the function `popup-menu' for a description of menu syntax.")
470
471 (defvar mode-popup-menu nil
472 "The mode-specific popup menu. Automatically buffer local.
473 This is appended to the default items in `global-popup-menu'.
474 See the function `popup-menu' for a description of menu syntax.")
475 (make-variable-buffer-local 'mode-popup-menu)
476
477 (defvar activate-popup-menu-hook nil
478 "Function or functions run before a mode-specific popup menu is made visible.
479 These functions are called with no arguments, and should interrogate and
480 modify the value of `global-popup-menu' or `mode-popup-menu' as desired.
481 Note: this hook is only run if you use `popup-mode-menu' for activating the
482 global and mode-specific commands; if you have your own binding for button3,
483 this hook won't be run.")
484
485 (defvar last-popup-menu-event nil
486 "The mouse event that invoked the last popup menu.
487 NOTE: This is EXPERIMENTAL and may change at any time.")
488
489 (defun popup-mode-menu (&optional event)
490 "Pop up a menu of global and mode-specific commands.
491 The menu is computed by combining `global-popup-menu' and `mode-popup-menu'
492 with any items derived from the `context-menu' property of the extent where the
493 button was clicked."
494 (interactive "_e")
495 (setq last-popup-menu-event
496 (or (and event (button-event-p event) event)
497 (let* ((mouse-pos (mouse-position))
498 (win (car mouse-pos))
499 (x (cadr mouse-pos))
500 (y (cddr mouse-pos))
501 (edges (window-pixel-edges win))
502 (winx (first edges))
503 (winy (second edges))
504 (x (+ x winx))
505 (y (+ y winy)))
506 (make-event 'button-press
507 `(button 3 x ,x y ,y channel ,(window-frame win)
508 timestamp ,(current-event-timestamp
509 (cdfw-console win)))))))
510 (run-hooks 'activate-popup-menu-hook)
511 (let* ((context-window (and event (event-window event)))
512 (context-point (and event (event-point event)))
513 (context-extents (and context-window
514 context-point
515 (extents-at context-point
516 (window-buffer context-window)
517 'context-menu)))
518 (context-menu-items
519 (apply 'append (mapcar #'(lambda (extent)
520 (extent-property extent 'context-menu))
521 context-extents))))
522 (popup-menu
523 (cond ((and global-popup-menu mode-popup-menu)
524 ;; Merge global-popup-menu and mode-popup-menu
525 (check-menu-syntax mode-popup-menu)
526 (let* ((title (car mode-popup-menu))
527 (items (cdr mode-popup-menu))
528 mode-filters)
529 ;; Strip keywords from local menu for attaching them at the top
530 (while (and items
531 (keywordp (car items)))
532 ;; Push both keyword and its argument.
533 (push (pop items) mode-filters)
534 (push (pop items) mode-filters))
535 (setq mode-filters (nreverse mode-filters))
536 ;; If mode-filters contains a keyword already present in
537 ;; `global-popup-menu', you will probably lose.
538 (append (list (car global-popup-menu))
539 mode-filters
540 (cdr global-popup-menu)
541 '("---" "---")
542 (if popup-menu-titles (list title))
543 (if popup-menu-titles '("---" "---"))
544 items
545 context-menu-items)))
546 (t
547 (append
548 (or mode-popup-menu
549 global-popup-menu
550 (error "No menu defined in this buffer"))
551 context-menu-items))))
552
553 (while (popup-up-p)
554 (dispatch-event (next-event)))
555
556 ))
557
558 (defun popup-buffer-menu (event)
559 "Pop up a copy of the Buffers menu (from the menubar) where the mouse is clicked."
560 (interactive "e")
561 (let ((window (and (event-over-text-area-p event) (event-window event)))
562 (bmenu nil))
563 (or window
564 (error "Pointer must be in a normal window"))
565 (select-window window)
566 (if current-menubar
567 (setq bmenu (assoc "%_Buffers" current-menubar)))
568 (if (null bmenu)
569 (setq bmenu (assoc "%_Buffers" default-menubar)))
570 (if (null bmenu)
571 (error "Can't find the Buffers menu"))
572 (popup-menu bmenu)))
573
574 (defun popup-menubar-menu (event)
575 "Pop up a copy of menu that also appears in the menubar."
576 (interactive "e")
577 (let ((window (and (event-over-text-area-p event) (event-window event)))
578 popup-menubar)
579 (or window
580 (error "Pointer must be in a normal window"))
581 (select-window window)
582 (and current-menubar (run-hooks 'activate-menubar-hook))
583 ;; #### Instead of having to copy this just to safely get rid of
584 ;; any nil what we should really do is fix up the internal menubar
585 ;; code to just ignore nil if generating a popup menu
586 (setq popup-menubar (delete nil (copy-sequence (or current-menubar
587 default-menubar))))
588 (popup-menu (cons "%_Menubar Menu" popup-menubar))
589 ))
590
591 (defun menu-call-at-event (form &optional event default-behavior-fallback)
592 "Call FORM while temporarily setting point to the position in EVENT.
593 NOTE: This is EXPERIMENTAL and may change at any time.
594
595 FORM is called the way forms in menu specs are: i.e. if a symbol, it's called
596 with `call-interactively', otherwise with `eval'. EVENT defaults to
597 `last-popup-menu-event', making this function especially useful in popup
598 menus. The buffer and point are set temporarily within a `save-excursion'.
599 If EVENT is not a mouse event, or was not over a buffer, nothing
600 happens unless DEFAULT-BEHAVIOR-FALLBACK is non-nil, in which case the
601 FORM is called normally."
602 (or event (setq event last-popup-menu-event))
603 (let ((buf (event-buffer event))
604 (p (event-closest-point event)))
605 (cond ((and buf p (> p 0))
606 (save-excursion
607 (set-buffer buf)
608 (goto-char p)
609 (if (symbolp form)
610 (call-interactively form)
611 (eval form))))
612 (default-behavior-fallback
613 (if (symbolp form)
614 (call-interactively form)
615 (eval form))))))
616
617 (global-set-key 'button3 'popup-mode-menu)
618 ;; shift button3 and shift button2 are reserved for Hyperbole
619 (global-set-key '(meta control button3) 'popup-buffer-menu)
620 ;; The following command is way too dangerous with Custom.
621 ;; (global-set-key '(meta shift button3) 'popup-menubar-menu)
622
623 ;; Here's a test of the cool new menu features (from Stig).
624
625 ;;(setq mode-popup-menu
626 ;; '("Test Popup Menu"
627 ;; :filter cdr
628 ;; ["this item won't appear because of the menu filter" ding t]
629 ;; "--:singleLine"
630 ;; "singleLine"
631 ;; "--:doubleLine"
632 ;; "doubleLine"
633 ;; "--:singleDashedLine"
634 ;; "singleDashedLine"
635 ;; "--:doubleDashedLine"
636 ;; "doubleDashedLine"
637 ;; "--:noLine"
638 ;; "noLine"
639 ;; "--:shadowEtchedIn"
640 ;; "shadowEtchedIn"
641 ;; "--:shadowEtchedOut"
642 ;; "shadowEtchedOut"
643 ;; "--:shadowDoubleEtchedIn"
644 ;; "shadowDoubleEtchedIn"
645 ;; "--:shadowDoubleEtchedOut"
646 ;; "shadowDoubleEtchedOut"
647 ;; "--:shadowEtchedInDash"
648 ;; "shadowEtchedInDash"
649 ;; "--:shadowEtchedOutDash"
650 ;; "shadowEtchedOutDash"
651 ;; "--:shadowDoubleEtchedInDash"
652 ;; "shadowDoubleEtchedInDash"
653 ;; "--:shadowDoubleEtchedOutDash"
654 ;; "shadowDoubleEtchedOutDash"
655 ;; ))
656
477 (defun get-popup-menu-response (menu-desc &optional event) 657 (defun get-popup-menu-response (menu-desc &optional event)
478 "Pop up the given menu and wait for a response. 658 "Pop up the given menu and wait for a response.
479 This blocks until the response is received, and returns the misc-user 659 This blocks until the response is received, and returns the misc-user
480 event that encapsulates the response. To execute it, you can do 660 event that encapsulates the response. To execute it, you can do
481 (funcall (event-function response) (event-object response)) 661 (funcall (event-function response) (event-object response))