1. xemacs
  2. hyperbole


hyperbole / wrolo-menu.el

;; FILE:         wrolo-menu.el
;; SUMMARY:      Pulldown and popup menus of Hyperbole rolo commands.
;; USAGE:        GNU Emacs Lisp Library
;; KEYWORDS:     hypermedia, matching, mouse
;; AUTHOR:       Bob Weiner
;; ORG:          BeOpen.com
;; ORIG-DATE:    28-Oct-94 at 10:59:44
;; LAST-MOD:     17-Jun-99 at 15:12:37 by Bob Weiner
;; Copyright (C) 1994-1995 BeOpen.com and the Free Software Foundation, Inc.
;; See the "HY-COPY" file for license information.
;; This file is part of Hyperbole.

;;; ************************************************************************
;;; Public variables
;;; ************************************************************************

;;; This definition is used by InfoDock and XEmacs.
(defconst infodock-wrolo-menu
    ["Manual"            (id-info "(hyperbole)Rolo") t]
    ["Add-Entry"         (id-tool-invoke 'rolo-add) t]
    ["Delete-Entry"      (id-tool-invoke 'rolo-kill) t]
    ["Display-Prior-Matches" (id-tool-invoke 'rolo-display-matches) t]
    ["Edit-Entry"        (id-tool-invoke 'rolo-edit) t]
    ["Edit-Rolo"         (id-tool-invoke
			  (function (lambda ()
				      (progn (require 'wrolo)
					     (find-file (car rolo-file-list))
					     (setq buffer-read-only nil)))))
    ["Insert-Entry-at-Point" (id-tool-invoke 'rolo-yank) t]
    ["Mail-to-Address"   (id-tool-invoke 'rolo-mail-to) t]
    ["Search-for-Regexp" (id-tool-invoke 'rolo-grep)  t]
    ["Search-for-String" (id-tool-invoke 'rolo-fgrep) t]
    ["Search-for-Word"   (id-tool-invoke 'rolo-word)  t]
    ["Sort-Entries"      (id-tool-invoke 'rolo-sort)  t]

(defconst wrolo-menu-common-body
     ["Scroll-Backward"     scroll-down             t]
     ["Scroll-Forward"      scroll-up               t]
     ["To-Beginning"        beginning-of-buffer     t]
     ["To-End"              end-of-buffer           t]
     ["To-Next-Entry"          outline-next-visible-heading t]
     ["To-Next-Same-Level"     outline-forward-same-level t]
     ["To-Previous-Entry"      outline-previous-visible-heading t]
     ["To-Previous-Same-Level" outline-backward-same-level t]
     ["Up-a-Level"             outline-up-heading t]
     ["Hide (Collapse)"      hide-subtree           t]
     ["Show (Expand)"        show-subtree           t]
     ["Show-All"             show-all               t]
     ["Show-Only-First-Line" hide-body              t]
  "The middle menu entries common to all Wrolo menus.")

;;; This definition is used by InfoDock only.
(defconst id-menubar-wrolo
      ["Help"                describe-mode                  t]
      ["Manual"              (id-info "(hyperbole.info)Rolo Keys") t]
      ["Toggle-Read-Only"    toggle-read-only               t]
      ["Write (Save as)"     write-file                     t]
      ["Quit"                (id-tool-quit '(kill-buffer nil))  t]
   '(["Edit-Entry-at-Point"  rolo-edit-entry         t]
     ["Mail-to-Address"      (id-tool-invoke 'rolo-mail-to) t])
   `(,@ wrolo-menu-common-body)
   '(["Next-Match"          rolo-next-match         t]
     ["Previous-Match"      rolo-previous-match     t])
   (list infodock-wrolo-menu)

;;; This definition is used by InfoDock and XEmacs.
(defconst id-popup-wrolo-menu
     ["Help"                describe-mode           t]
     ["Manual"              (id-info "(hyperbole.info)Rolo Keys") t]
     ["Edit-Entry-at-Point" rolo-edit-entry         t]
     ["Locate-Entry-Isearch" rolo-locate        t]
     ["Next-Match"          rolo-next-match         t]
     ["Previous-Match"      rolo-previous-match     t]
   `(,@ wrolo-menu-common-body)
   (list infodock-wrolo-menu)
     ["Quit"                (id-tool-quit 'rolo-quit) t])

;;; ************************************************************************
;;; Public functions
;;; ************************************************************************

;;; This definition is used only by XEmacs and Emacs19.
(defun wrolo-menubar-menu ()
  "Add a Hyperbole Rolo menu to the rolo match buffer menubar."
  (cond ((fboundp 'popup-mode-menu)
	 (setq mode-popup-menu id-popup-wrolo-menu))
	 (define-key wrolo-mode-map 'button3 'wrolo-popup-menu))
	(t ;; hyperb:emacs19-p
	 (define-key wrolo-mode-map [down-mouse-3] 'wrolo-popup-menu)
	 (define-key wrolo-mode-map [mouse-3] nil)))
  (if (and (boundp 'current-menubar)
	   (or hyperb:emacs19-p current-menubar)
	   (not (car (find-menu-item current-menubar '("Wrolo")))))
	(set-buffer-menubar (copy-sequence current-menubar))
	(if (fboundp 'add-submenu)
	    (add-submenu nil id-popup-wrolo-menu)
	  (add-menu nil (car id-popup-wrolo-menu)
		    (cdr id-popup-wrolo-menu))))))

;;; This definition is used only by XEmacs and Emacs19.
(defun wrolo-popup-menu (event)
  "Popup the Hyperbole Rolo match buffer menu."
  (interactive "@e")
  (mouse-set-point event)
   ;; GNU Emacs
   ((fboundp 'popup-menu-internal)
    (popup-menu-internal id-popup-wrolo-menu '*id-popup-wrolo-menu*))
   ;; XEmacs
   (t (popup-menu id-popup-wrolo-menu))))

(cond ((null hyperb:window-system))
      ((featurep 'infodock)
       ;; InfoDock under a window system
       (require 'id-menubars)
       (id-menubar-set 'wrolo-mode 'id-menubar-wrolo))
       ;; XEmacs under a window system
       (add-hook 'wrolo-mode-hook 'wrolo-menubar-menu))
       ;; Emacs 19 under a window system
       (require 'lmenu)
       (add-hook 'wrolo-mode-hook 'wrolo-menubar-menu)))

(provide 'wrolo-menu)