home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / MouseAndMenuEmacs / x-menus.el < prev    next >
Encoding:
Text File  |  1990-05-31  |  7.8 KB  |  206 lines
  1. ;;; Crude, primitive X Menu facility. But it works...
  2. ;;; Russell A. Ritchie, Scottish HCI Centre, <russell@uk.ac.strath.hci>.
  3. ;;; Mon Feb 13 16:33:20 1989 
  4.  
  5. (require 'x-mouse)
  6. (require 'x-fns)
  7. (provide 'x-menus)
  8.  
  9. ;;; The extant X menu facilities don't provide pull-right (or walking)
  10. ;;; menus, so this code cannot parse specifications as defined in
  11. ;;; 'hci-menus.el', and used by 'sun-menus.el' and 'term-menus.el'.
  12.  
  13. ;;; Thus 'inhibit-key-reminders' is undefined when this file is loaded:
  14.  
  15. (defvar inhibit-key-reminders nil
  16.   "*If non-nil (default is nil) menus will not attempt to display key
  17. bindings for options.")
  18.  
  19. (defvar x-menu-mouse-binding x-button-right
  20.   "*The mouse binding that the pop-up menu function is bound to.")
  21.  
  22. (defun prefix-arg-supplied (command)
  23.   "Declare in a menu entry that COMMAND is called as if typed with a C-u prefix."
  24.   (let ((current-prefix-arg (list 4)))
  25.     (call-interactively command)))
  26.  
  27. (defun defXmenu (menu-name menu-spec)
  28.   "Make MENU-NAME an X menu with MENU-SPEC as it's contents.
  29. If  inhibit-key-reminders  is non-nil display the keystroke that 
  30. will do the same thing as the menu option on the menu, if it exists."  
  31.   (set menu-name menu-spec)    ; For X a menu is just it's item-list.
  32.   (put menu-name 'key-reminders (x-menu-keybindings menu-spec))
  33.   menu-spec)
  34.  
  35. (defun x-menu-keybindings (menu-spec-list)
  36.   "Return MENU-SPEC-LIST with key bindings for commands added to the
  37. end of the menu item if the command is bound to a key."
  38.   (let ((name (car menu-spec-list))
  39.     (menus (cdr menu-spec-list))
  40.     ;; Declare these outside loop for speed 
  41.     new-menu-items result)
  42.     (while menus
  43.       (let* ((menu (car menus))
  44.          (menu-name (car menu))
  45.          (menu-items (cdr menu)))
  46.     (setq new-menu-items nil)
  47.     (while menu-items
  48.       (let* ((menu-form (cdr (car menu-items)))
  49.          (menu-form-car (car menu-form))
  50.          (prefix-arg-supplied-p nil)
  51.          (command 
  52.           (cond ((eq menu-form-car 'call-interactively)
  53.              (eval (car (cdr menu-form))))
  54.             ((eq menu-form-car 'prefix-arg-supplied)
  55.              (setq prefix-arg-supplied-p t)
  56.              (eval (car (cdr menu-form))))
  57.             (t (and (null (cdr menu-form)) ; No arguments supplied
  58.                 menu-form-car))))
  59.          (keystrokes 
  60.           (if (commandp command)
  61.               (if prefix-arg-supplied-p
  62.               (mapcar
  63.                '(lambda (x) (concat "" x))
  64.                (where-is-internal command (current-local-map)))
  65.             (where-is-internal command (current-local-map))))))
  66.         (setq new-menu-items
  67.           (append new-menu-items
  68.               (list
  69.                (if keystrokes
  70.                    (cons 
  71.                 (format "%s [%s]"
  72.                     (car (car menu-items))
  73.                     (mapconcat
  74.                      'key-description keystrokes " or "))
  75.                 menu-form)
  76.                  ;; No keybinding
  77.                  (car menu-items))))      
  78.           menu-items (cdr menu-items))))
  79.       (setq result (append result (list (cons menu-name new-menu-items)))
  80.         menus (cdr menus))))
  81.     (cons name result)))
  82.  
  83. ;;; defvars are used for defining these menus to provide documentation
  84. ;;; strings, and also to make sure loading this file after ".emacs"
  85. ;;; does not redefine any preferences that the luser may set there,
  86. ;;; rather than using term-setup-hook.
  87.  
  88. (defXmenu 'x-mouse-default-menu
  89.   '("Emacs-X Menu" 
  90.     ("Command Menu"
  91.      ("Undo last edit" call-interactively 'undo)
  92.      ("Quit from complex command or unknown state"
  93.       call-interactively 'keyboard-quit)
  94.      ("Exit from Emacs" x-mouse-save-buffers-kill-emacs))
  95.     ("File and Buffer Menu" 
  96.      ("Find File" call-interactively 'find-file)
  97.      ("Find File in other window" call-interactively 'find-file-other-window)
  98.      ("Save File" call-interactively 'save-buffer)
  99.      ("Save File (prompting for a name)" call-interactively 'write-file)
  100.      ("List Buffers" call-interactively 'electric-buffer-list))
  101.     ("Word Processing Menu"
  102.      ("LaTeX" new-buffer-other-window 'LaTeX-mode ".tex" t)
  103.      ("TeX" new-buffer-other-window 'TeX-mode ".tex")
  104.      ("Nroff" new-buffer-other-window 'nroff-mode ".roff")
  105.      ("Scribe" new-buffer-other-window 'scribe-mode ".mss")
  106.      ("Text" new-buffer-other-window 'text-mode ".text"))
  107.     ("Programming Menu"
  108.      ("Lisp" new-buffer-other-window 'lisp-mode ".lisp")
  109.      ("Common Lisp" new-buffer-other-window 'common-lisp-mode ".cl")
  110.      ;; ("Kyoto Common Lisp" new-buffer-other-window 'kyoto-lisp-mode ".lsp")
  111.      ("Franz Lisp" new-buffer-other-window 'franz-lisp-mode ".l")
  112.      ("Emacs Lisp" new-buffer-other-window 'emacs-lisp-mode ".el")
  113.      ("Scheme" new-buffer-other-window 'scheme-mode ".scm")
  114.      ("PROLOG" new-buffer-other-window 'prolog-mode ".pl")
  115.      ("Ada" new-buffer-other-window 'ada-mode ".ada") ; see below
  116.      ("C" new-buffer-other-window 'c-mode ".c")
  117.      ("FORTRAN" new-buffer-other-window 'fortran-mode ".f")
  118.      ("Modula-2" new-buffer-other-window 'modula-2-mode ".mod")) 
  119.     ("Tool Menu"
  120.      ("Read Mail" rmail)
  121.      ("Send Mail" mail)
  122.      ("Dired" call-interactively 'dired)
  123.      ("Shell" shell)
  124.      ("Telnet" telnet)
  125.      ("Terminal Emulator" call-interactively 'terminal-emulator))
  126.     ("Help Menu"
  127.      ("Enter Tutorial introduction to Emacs" help-with-tutorial)
  128.      ("Enter \"Info\", the documentation browser" info)
  129.      ("Command apropos" call-interactively 'command-apropos)
  130.      ("Where is command" call-interactively 'where-is))
  131.     ("Describe Menu"
  132.      ("Describe Mode" describe-mode)
  133.      ("Describe mouse bindings" x-mouse-help)
  134.      ("Describe single key binding" call-interactively 'describe-key)
  135.      ("Describe all key bindings" describe-bindings)
  136.      ("Describe mode" describe-mode)
  137.      ("Describe function" call-interactively 'describe-function)
  138.      ("Describe variable" call-interactively 'describe-variable)
  139.      ("Describe syntax" describe-syntax))
  140.     ("Miscellaneous Menu"
  141.      ("Emacs ordering information" describe-distribution)
  142.      ("Emacs copying information" describe-copying)
  143.      ("Emacs recent changes" view-emacs-news)
  144.      ("Emacs [absence of] warranty information" describe-no-warranty))))
  145.  
  146. (autoload 'ada-mode "ada")
  147.  
  148. (defvar global-x-mouse-menu
  149.   'x-mouse-default-menu
  150.   "*The default global X mouse menu.")
  151.  
  152. (defvar x-mouse-help-menu
  153.   (defXmenu 'x-mouse-help-menu
  154.     '("Mouse regions"
  155.       ("Choose a mouse region:"
  156.        ("Text" x-mouse-report-bindings "x-mouse-text-map")
  157.        ("Scrollbar" x-mouse-report-bindings "x-mouse-scrollbar-map")
  158.        ("Modeline" x-mouse-report-bindings "x-mouse-modeline-map")
  159.        ("Minibuffer" x-mouse-report-bindings "x-mouse-minibuffer-map"))))
  160.   "*The default mouse help menu for X.")
  161.  
  162. (defvar local-x-mouse-menu nil
  163.   "*The local X menu for the current major mode.")
  164. (make-variable-buffer-local 'local-x-mouse-menu)
  165.  
  166. (defun x-mouse-menu (arg &optional menu)
  167.   "Make a (mode-sensitive) menu pop up, offering various command
  168. options. If optional arg MENU is supplied, use as menu to pop up."
  169.   (eval-in-window
  170.     x-mouse-window
  171.     (let ((menu (or menu local-x-mouse-menu global-x-mouse-menu)))
  172.       (let ((selection (x-popup-menu x-mouse-pos
  173.                      (if inhibit-key-reminders
  174.                      (symbol-value menu)
  175.                        (get menu 'key-reminders)))))
  176.     (if selection
  177.         (eval selection))))))
  178.  
  179. (defun x-mouse-other-menus ()
  180.   "Pop up menu of things that should be available from all menus, but not at top-level."
  181.   (x-mouse-menu x-mouse-pos global-x-mouse-menu))
  182.  
  183. (defun x-mouse-help ()
  184.   "Pop up a menu of the available regions and describe the mouse bindings in the selection."
  185.   (interactive)
  186.   (x-mouse-menu x-mouse-pos 'x-mouse-help-menu))
  187.  
  188. (defun set-mode-menu (menu)
  189.   "Make the current local X menu be MENU."
  190.   (setq local-x-mouse-menu menu))
  191.  
  192. (global-set-mouse 'text x-menu-mouse-binding 'x-mouse-menu) 
  193.  
  194. (defvar x-mouse-exit-menu
  195.   (defXmenu 'x-mouse-exit-menu
  196.     '("Exit Menu"
  197.       ("Confirm exit from Emacs?"
  198.        ("Yes" save-buffers-kill-emacs)
  199.        ("No" error "Emacs exit aborted..."))))
  200.   "*The default mouse exit query menu for X.")
  201.  
  202. (defun x-mouse-save-buffers-kill-emacs ()
  203.   "Use the mouse to confirm whether or not to call the Emacs exit function."
  204.   (interactive)
  205.   (x-mouse-menu x-mouse-pos 'x-mouse-exit-menu))
  206.