;;; x-menubar.el --- Menubar and popup-menu support for X.

;; Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
;; Copyright (C) 1995 Sun Microsystems.

;; This file is part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with Xmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

(defconst default-menubar
  (purecopy-menubar
   '(
     ("File"
      :filter file-menu-filter
      ["Open..."		find-file		t]
      ["Open in Other Window..." find-file-other-window	t]
      ["Open in New Frame..."	find-file-other-frame	t]
      ["Insert File..." 	insert-file		t]
      ["View File..."		view-file		t]
      "------"
      ["Save"			save-buffer		t  nil]
      ["Save As..."		write-file		t]
      ["Save Some Buffers"	save-some-buffers	t]
      "-----"
      ["Print Buffer"		lpr-buffer		t  nil]
      ["Pretty-Print Buffer"	ps-print-buffer-with-faces t  nil]
      "-----"
      ["New Frame"		make-frame		t]
      ["Delete Frame"		delete-frame		t]
      "-----"
      ["Split Window"		split-window-vertically t]
      ["Un-Split (Keep This)"	delete-other-windows	(not (one-window-p t))]
      ["Un-Split (Keep Others)"	delete-window		(not (one-window-p t))]
      "-----"
      ["Revert Buffer"		revert-buffer		 t  nil]
      ["Delete Buffer"		kill-this-buffer	 t  nil]
      "-----"
      ["Exit XEmacs"		save-buffers-kill-emacs	t]
      )

     ("Edit"
      :filter edit-menu-filter
      ["Undo"			advertised-undo		   t]
      ["Cut"			x-kill-primary-selection   t]
      ["Copy"			x-copy-primary-selection   t]
      ["Paste"			x-yank-clipboard-selection t]
      ["Clear"			x-delete-primary-selection t]
      "----"
      ["Search..."		isearch-forward		t]
      ["Search Backward..."	isearch-backward	t]
      ["Replace..."		query-replace		t]
      "----"
      ["Search (Regexp)..."	isearch-forward-regexp	t]
      ["Search Backward (Regexp)..." isearch-backward-regexp t]
      ["Replace (Regexp)..."	query-replace-regexp	t]
      "----"
      ["Goto Line..."		goto-line		t]
      ["What Line"		what-line		t]
      "----"
      ["Start Macro Recording"	start-kbd-macro	      (not defining-kbd-macro)]
      ["End Macro Recording"	end-kbd-macro		defining-kbd-macro]
      ["Execute Last Macro"	call-last-kbd-macro	last-kbd-macro]
      "----"
      ["Show Message Log"	show-message-log	t]
      )

     ("Apps"
      ["Read Mail (VM)..."	vm			t]
      ["Read Mail (MH)..."	(mh-rmail t)		t]
      ["Send mail..."		mail			t]
      ["Usenet News"		gnus			t]
      ["Browse the Web"		w3			t]
      ["Gopher"			gopher			t]
      ["Hyperbole..."		hyperbole		t]
      "----"
      ["Spell-Check Buffer"	ispell-buffer		t]
      ["Emulate VI"		viper-mode		t]
      "----"
      ("Calendar"
       ["3-Month Calendar"	calendar		t]
       ["Diary"			diary			t]
       ["Holidays"		holidays		t]
       ;; we're all pagans at heart ...
       ["Phases of the Moon"	phases-of-moon		t]
       ["Sunrise/Sunset"	sunrise-sunset		t]
       )
      ("Games"
       ["Quote from Zippy"	yow			t]
       ["Psychoanalyst"		doctor			t]
       ["Psychoanalyze Zippy!"	psychoanalyze-pinhead	t]
       ["Random Flames"		flame			t]
       ["Dunnet (Adventure)"	dunnet			t]
       ["Towers of Hanoi"	hanoi			t]
       ["Game of Life"		life			t]
       ["Multiplication Puzzle"	mpuz			t]
       )
      )

     ("Options"
      ["Read Only" (toggle-read-only)
       :style toggle :selected buffer-read-only]
      ("Editing Options"
       ["Overstrike" (progn
		       (overwrite-mode current-prefix-arg)
		       (setq-default overwrite-mode overwrite-mode))
	:style toggle :selected overwrite-mode]
       ["Case Sensitive Search" (progn
				  (setq case-fold-search (not case-fold-search))
				  (setq-default case-fold-search
						case-fold-search))
	:style toggle :selected (not case-fold-search)]
       ["Case Matching Replace" (setq case-replace (not case-replace))
	:style toggle :selected case-replace]
       ["Auto Delete Selection" (if (memq 'pending-delete-pre-hook
					  pre-command-hook)
				    (pending-delete-off nil)
				  (pending-delete-on nil))
	:style toggle
	:selected (memq 'pending-delete-pre-hook pre-command-hook)]
       ["Active Regions" (setq zmacs-regions (not zmacs-regions))
	:style toggle :selected zmacs-regions]
       ["Mouse Paste At Text Cursor" (setq mouse-yank-at-point
					   (not mouse-yank-at-point))
	:style toggle :selected mouse-yank-at-point]
       )
      ("General Options"
       ["Teach Extended Commands" (setq teach-extended-commands-p
					(not teach-extended-commands-p))
	:style toggle :selected teach-extended-commands-p]
       ["Debug On Error" (setq debug-on-error (not debug-on-error))
	:style toggle :selected debug-on-error]
       ["Debug On Quit" (setq debug-on-quit (not debug-on-quit))
	:style toggle :selected debug-on-quit]
       )
      ("\"Other Window\" Location"
       ["Always in Same Frame"
	(setq get-frame-for-buffer-default-instance-limit nil)
	:style radio
	:selected (null get-frame-for-buffer-default-instance-limit)]
       ["Other Frame (2 Frames Max)"
	(setq get-frame-for-buffer-default-instance-limit 2)
	:style radio
	:selected (eq 2 get-frame-for-buffer-default-instance-limit)]
       ["Other Frame (3 Frames Max)"
	(setq get-frame-for-buffer-default-instance-limit 3)
	:style radio
	:selected (eq 3 get-frame-for-buffer-default-instance-limit)]
       ["Other Frame (4 Frames Max)"
	(setq get-frame-for-buffer-default-instance-limit 4)
	:style radio
	:selected (eq 4 get-frame-for-buffer-default-instance-limit)]
       ["Other Frame (5 Frames Max)"
	(setq get-frame-for-buffer-default-instance-limit 5)
	:style radio
	:selected (eq 5 get-frame-for-buffer-default-instance-limit)]
       ["Always Create New Frame"
	(setq get-frame-for-buffer-default-instance-limit 0)
	:style radio
	:selected (eq 0 get-frame-for-buffer-default-instance-limit)]
       "-----"
       ["Temp Buffers Always in Same Frame"
	(setq temp-buffer-show-function 'show-temp-buffer-in-current-frame)
	:style radio
	:selected (eq temp-buffer-show-function
		      'show-temp-buffer-in-current-frame)]
       ["Temp Buffers Like Other Buffers"
	(setq temp-buffer-show-function nil)
	:style radio
	:selected (null temp-buffer-show-function)]
       )

      "-----"
      ("Syntax Highlighting" 
       ["None" (progn
		 (font-lock-mode 0)
		 (fast-lock-mode 0))
	:style radio :selected (null font-lock-mode)]
       ["Fonts" (progn (require 'font-lock)
		       (font-lock-use-default-fonts)
		       (setq font-lock-use-fonts t
			     font-lock-use-colors nil)
		       (font-lock-mode 1))
	:style radio
	:selected (and font-lock-mode
		       font-lock-use-fonts)]
       ["Colors" (progn (require 'font-lock)
			(font-lock-use-default-colors)
			(setq font-lock-use-colors t 
			      font-lock-use-fonts nil)
			(font-lock-mode 1))
	:style radio
	:selected (and font-lock-mode
		       font-lock-use-colors)]
       "-----"
       ["Less" (progn (require 'font-lock)
		      (font-lock-use-default-minimal-decoration)
		      (setq font-lock-use-maximal-decoration nil)
		      (font-lock-mode 0)
		      (font-lock-mode 1))
	:style radio
	:selected (and font-lock-mode
		       (not font-lock-use-maximal-decoration))]
       ["More" (progn (require 'font-lock)
		      (font-lock-use-default-maximal-decoration)
		      (setq font-lock-use-maximal-decoration t)
		      (font-lock-mode 0)
		      (font-lock-mode 1))
	:style radio
	:selected (and font-lock-mode
		       font-lock-use-maximal-decoration)]
       "-----"
       ["Fast" (progn (require 'fast-lock)
		      (if fast-lock-mode
			  (progn
			    (fast-lock-mode 0)
			    ;; this shouldn't be necessary so there has to
			    ;; be a redisplay bug lurking somewhere (or
			    ;; possibly another event handler bug)
			    (redraw-modeline))
			(if font-lock-mode
			    (progn
			      (fast-lock-mode 1)
			      (redraw-modeline)))))
	:active font-lock-mode
	:style toggle
	:selected fast-lock-mode]
       ["Auto-Fontify" (if (not (featurep 'font-lock))
			   (progn
			     (setq font-lock-auto-fontify t)
			     (require 'font-lock))
			 (setq font-lock-auto-fontify
			       (not font-lock-auto-fontify)))
	:style toggle
	:selected (and (featurep 'font-lock) font-lock-auto-fontify)]
       )
      ("Paren Highlighting"
       ["None" (paren-set-mode -1)
	:style radio :selected (not paren-mode)]
       ["Blinking Paren" (paren-set-mode 'blink-paren)
	:style radio :selected (eq paren-mode 'blink-paren)]
       ["Steady Paren" (paren-set-mode 'paren)
	:style radio :selected (eq paren-mode 'paren)]
       ["Expression" (paren-set-mode 'sexp)
	:style radio :selected (eq paren-mode 'sexp)]
;;;       ["Nested Shading" (paren-set-mode 'nested)
;;;        :style radio :selected (eq paren-mode 'nested)]
       )
      "-----"
      ("Frame Appearance"
       ["Scrollbars" (if (= (specifier-instance scrollbar-width) 0)
			 (progn
			   (set-specifier scrollbar-width 15)
			   (set-specifier scrollbar-height 15))
		       (set-specifier scrollbar-width 0)
		       (set-specifier scrollbar-height 0))
	:style toggle :selected (> (specifier-instance scrollbar-width) 0)]
       ["3D Modeline"
	(progn
	  (if (zerop (specifier-instance modeline-shadow-thickness))
	      (set-specifier modeline-shadow-thickness 2)
	    (set-specifier modeline-shadow-thickness 0))
	  (redraw-modeline t))
	:style toggle :selected
	(let ((thickness
	       (specifier-instance modeline-shadow-thickness)))
	  (and (integerp thickness)
	       (> thickness 0)))]
       ["Truncate Lines" (progn
			   (setq truncate-lines (not truncate-lines))
			   (setq-default truncate-lines truncate-lines))
	:style toggle :selected truncate-lines]
       ["Bar Cursor" (progn
		       (setq bar-cursor (not bar-cursor))
		       (force-cursor-redisplay))
	:style toggle :selected bar-cursor]
;     ["Line Numbers" (line-number-mode nil)
;      :style toggle :selected line-number-mode]
      )
      ("Menubar Appearance"
       ["Buffers Menu Length..."
	(progn
	  (setq buffers-menu-max-size
		(read-number
		 "Enter number of buffers to display (or 0 for unlimited): "))
	  (if (eq buffers-menu-max-size 0) (setq buffers-menu-max-size nil)))
	t]
       ["Buffers Sub-Menus" (setq complex-buffers-menu-p
				  (not complex-buffers-menu-p))
	:style toggle :selected complex-buffers-menu-p]
       ["Frame-Local Font Menu" (setq font-menu-this-frame-only-p
				    (not font-menu-this-frame-only-p))
	:style toggle :selected font-menu-this-frame-only-p]
       ["Ignore Scaled Fonts" (setq font-menu-ignore-scaled-fonts
				    (not font-menu-ignore-scaled-fonts))
	:style toggle :selected font-menu-ignore-scaled-fonts]
       )
      ("Toolbar Appearance"
       ["Visible" (menubar-toggle-toolbar-visibility)
	:style toggle :selected
	(menubar-toolbar-visible-p)]
       ["Captioned" (if (featurep 'toolbar)
			(set-specifier toolbar-buttons-captioned-p
				       (not (specifier-instance
					     toolbar-buttons-captioned-p))))
	:style toggle :selected
	(and (featurep 'toolbar)
	     (specifier-instance toolbar-buttons-captioned-p))]
       ("Default Location"
	["Top" (menubar-change-default-toolbar-position 'top nil)
	 :style radio :selected (eq (default-toolbar-position) 'top)]
	["Bottom" (menubar-change-default-toolbar-position 'bottom nil)
	 :style radio :selected (eq (default-toolbar-position) 'bottom)]
	["Left" (menubar-change-default-toolbar-position 'left nil)
	 :style radio :selected (eq (default-toolbar-position) 'left)]
	["Right" (menubar-change-default-toolbar-position 'right nil)
	 :style radio :selected (eq (default-toolbar-position) 'right)]
	)
       )
      "-----"
      ["Edit Faces..." edit-faces t]
      ("Font"   :filter font-menu-family-constructor)
      ("Size"	:filter font-menu-size-constructor)
      ("Weight"	:filter font-menu-weight-constructor)
      "-----"
      ["Save Options" save-options-menu-settings t]
      )
     
     ("Buffers"
      :filter buffers-menu-filter
      ["List All Buffers" list-buffers t]
      "--"
      )
     
     ("Tools"
      ["Grep..."		grep			t]
      ["Compile..."		compile			t]
      ["Shell Command..."	shell-command		t]
      ["Shell Command on Region..."
				shell-command-on-region (region-exists-p)]
      ["Debug (GDB)..."		gdb			t]
      ["Debug (DBX)..."		dbx			t]
      "-----"
      ["OO-Browser..."		oobr			t]
      ("Tags"
       ["Find..."		find-tag		t]
       ["Find Other Window..."	find-tag-other-window	t]
       ["Tags Search..."	tags-search		t]
       ["Tags Replace..."	tags-query-replace	t]
       "-----"
       ["Continue"		tags-loop-continue	t]
       ["Pop stack"		pop-tag-mark		t]
       ["Apropos..."		tags-apropos		t]))

     nil		; the partition: menus after this are flushright

     ("Help"
      ["About XEmacs..."	about-xemacs		t]
      "-----"
      ["XEmacs WWW Page"	xemacs-www-page		t]
      ["Newest XEmacs FAQ via WWW"	xemacs-www-faq	t]
      ["XEmacs FAQ (local)"	xemacs-local-faq	t]
      ["XEmacs Tutorial"	help-with-tutorial	t]
      ["XEmacs News"		view-emacs-news		t]
      "-----"
      ["Info (Detailed Docs)"	info			t]
      ("Lookup in Info"
       ["Key/Mouse Binding..."	Info-goto-emacs-key-command-node t]
       ["Command..."		Info-goto-emacs-command-node t]
       ["Elisp Function..."	Info-elisp-ref		t]
       ["Topic..."		Info-query		t])
      ["Package Browser"	finder-by-keyword	t]
      ["Describe Mode"		describe-mode		t]
      ["Apropos..."		hyper-apropos		t]
      ["Super Apropos..."	super-apropos		t]
      "-----"
      ["Describe Key/Mouse..."	describe-key		t]
      ["List Key Bindings"	describe-bindings	t]
      ["List Mouse Bindings"	describe-pointer	t]
      "-----"
      ["Describe Function..."	describe-function	t]
      ["Describe Variable..."	describe-variable	t]
      ["Where Is Command..."	where-is		t]
      "-----"
      ["Unix Manual..."		manual-entry		t]
      ("Misc"
       ["Describe No Warranty"	describe-no-warranty	t]
       ["Describe XEmacs License" describe-copying	t]
       ["Getting the Latest Version"	describe-distribution	t])
      )
     )))


;; These functions make a very big assumption: that you never
;; maninpulate the things they do other than through them.
;; Cheap.  Cheap.  Cheap.   #### Add toolbar-visible-p for 19.14.

;; Change the default toolbar location and adjust the toolbar width
;; and height accordingly.
;; #### The height/width is what is hard-coded in src/toolbar.h
(defun menubar-change-default-toolbar-position (new-location &optional force)
  (let ((top-height (if (eq new-location 'top) 37 0))
	(bottom-height (if (eq new-location 'bottom) 37 0))
	(left-width (if (eq new-location 'left) 37 0))
	(right-width (if (eq new-location 'right) 37 0)))
    (if (not (eq new-location 'none))
	(set-default-toolbar-position new-location))
    (if (or force (menubar-toolbar-visible-p))
	(progn
	  (set-specifier top-toolbar-height top-height)
	  (set-specifier bottom-toolbar-height bottom-height)
	  (set-specifier left-toolbar-width left-width)
	  (set-specifier right-toolbar-width right-width)))))

;; Return nil if the size of all 4 toolbars is 0, otherwise t.
(defun menubar-toolbar-visible-p ()
  (if (not (featurep 'toolbar))
      nil
    (if (and (eq (specifier-instance top-toolbar-height) 0)
	     (eq (specifier-instance bottom-toolbar-height) 0)
	     (eq (specifier-instance left-toolbar-width) 0)
	     (eq (specifier-instance right-toolbar-width) 0))
	nil
      t)))
      
;; If the toolbars are visible according to menubar-toolbar-visible-p
;; then set the size of all 4 to 0.  Otherwise set the default toolbar
;; location's size to the default size.
(defun menubar-toggle-toolbar-visibility ()
  (if (featurep 'toolbar)
      (if (not (menubar-toolbar-visible-p))
	  (menubar-change-default-toolbar-position (default-toolbar-position)
						   t)
	(menubar-change-default-toolbar-position 'none t))))


;;; Add Load Init button to menubar when starting up with -q
(defun maybe-add-init-button ()
  ;; by Stig@hackvan.com
  (if init-file-user
      nil
    (add-menu-button nil
		     ["Load .emacs"
		      (progn (delete-menu-item '("Load .emacs"))
			     (load-user-init-file (user-login-name)))
		      t]
		     "Help")
    ))

(add-hook 'before-init-hook 'maybe-add-init-button)


;;; The File and Edit menus

(defvar put-buffer-names-in-file-menu t)

;; The sensitivity part of this function could be done by just adding forms
;; to evaluate to the menu items themselves; that would be marginally less
;; efficient but not perceptibly so (I think).  But in order to change the
;; names of the Undo menu item and the various things on the File menu item,
;; we need to use a hook.

(defun file-menu-filter (menu-items)
  "Incrementally update the file menu.
This function changes the arguments and sensitivity of these File menu items:

  Delete Buffer  has the name of the current buffer appended to it.
  Print Buffer   has the name of the current buffer appended to it.
  Pretty-Print Buffer
		 has the name of the current buffer appended to it.
  Save           has the name of the current buffer appended to it, and is
                 sensitive only when the current buffer is modified.
  Revert Buffer  has the name of the current buffer appended to it, and is
                 sensitive only when the current buffer has a file.
  Delete Frame   sensitive only when there is more than one frame.

The name of the current buffer is only appended to the menu items if
`put-buffer-names-in-file-menu' is non-nil.  This behavior is the default."
  (let* ((bufname (buffer-name))
	 (result menu-items)		; save pointer to start of menu.
	 name
	 item)
    ;; the contents of the menu items in the file menu are destructively
    ;; modified so that there is as little consing as possible.  This is okay.
    ;; As soon as the result is returned, it is converted to widget_values
    ;; inside lwlib and the lisp menu-items can be safely modified again. 
    (while (setq item (pop menu-items))
      (if (vectorp item)
	  (progn
	    (setq name (aref item 0))
	    (and put-buffer-names-in-file-menu
		 (member name '("Save" "Revert Buffer" "Print Buffer"
				"Pretty-Print Buffer" "Delete Buffer"))
		 (>= 4 (length item))
		 (aset item 3 bufname))
	    (and (string= "Save" name)
		 (aset item 2 (buffer-modified-p)))
	    (and (string= "Revert Buffer" name)
		 (aset item 2 (not (not (or buffer-file-name
					    revert-buffer-function)))))
	    (and (string= "Delete Frame" name)
		 (aset item 2 (not (eq (next-frame) (selected-frame)))))
	    )))
    result))

(defun edit-menu-filter (menu-items)
  "For use as an incremental menu construction filter.
This function changes the sensitivity of these Edit menu items:

  Cut    sensitive only when emacs owns the primary X Selection.
  Copy   sensitive only when emacs owns the primary X Selection.
  Clear  sensitive only when emacs owns the primary X Selection.
  Paste  sensitive only when there is an owner for the X Clipboard Selection.
  Undo   sensitive only when there is undo information.
         While in the midst of an undo, this is changed to \"Undo More\"."
  (let* (item
	name
	(result menu-items)		; save pointer to head of list
	(x-dev (eq 'x (device-type (selected-device))))
	(emacs-owns-selection-p (and x-dev (x-selection-owner-p)))
	(clipboard-exists-p (and x-dev (x-selection-exists-p 'CLIPBOARD)))
;;;       undo-available undoing-more
;;;       (undo-info-available (not (null (and (not (eq t buffer-undo-list))
;;;                                 (if (eq last-command 'undo)
;;;                                     (setq undoing-more
;;;                                           (and (boundp 'pending-undo-list)
;;;                                          pending-undo-list)
;;;                                   buffer-undo-list))))))
	undo-name undo-state
	)
    ;; As with file-menu-filter, menu-items are destructively modified.
    ;; This is OK.
    (while (setq item (pop menu-items))
      (if (vectorp item)
	  (progn
	    (setq name (aref item 0))
	    (and (member name '("Cut" "Copy" "Clear"))
		 (aset item 2 emacs-owns-selection-p))
	    (and (string= name "Paste")
		 (aset item 2 clipboard-exists-p))
	    (and (member name '("Undo" "Undo More"))
		 (progn
		   ;; we could also do this with the third field of the item.
		   (if (eq last-command 'undo)
		       (setq undo-name "Undo More"
			     undo-state (not (null (and (boundp 'pending-undo-list)
							pending-undo-list))))
		     (setq undo-name "Undo"
			   undo-state (and (not (eq buffer-undo-list t))
					   (not (null
						 (or buffer-undo-list
						     (and (boundp 'pending-undo-list)
							  pending-undo-list)))))))
		   (if buffer-read-only (setq undo-state nil))
		   (aset item 0 undo-name)
		   (aset item 2 undo-state)
		   ))
      )))
    result))


;;; The Buffers menu

;; this version is too slow
(defun slow-format-buffers-menu-line (buffer)
  "Returns a string to represent the given buffer in the Buffer menu.
nil means the buffer shouldn't be listed.  You can redefine this."
  (if (string-match "\\` " (buffer-name buffer))
      nil
    (save-excursion
     (set-buffer buffer)
     (let ((size (buffer-size)))
       (format "%s%s %-19s %6s %-15s %s"
	       (if (buffer-modified-p) "*" " ")
	       (if buffer-read-only "%" " ")
	       (buffer-name)
	       size
	       mode-name
	       (or (buffer-file-name) ""))))))

(defun format-buffers-menu-line (buffer)
  "Returns a string to represent the given buffer in the Buffer menu.
nil means the buffer shouldn't be listed.  You can redefine this."
  (if (string-match "\\` " (setq buffer (buffer-name buffer)))
      nil
    buffer))

(defvar buffers-menu-max-size 20
  "*Maximum number of entries which may appear on the \"Buffers\" menu.
If this is 10, then only the ten most-recently-selected buffers will be
shown.  If this is nil, then all buffers will be shown.  Setting this to
a large number or nil will slow down menu responsiveness.")

(defvar complex-buffers-menu-p nil
  "*If true, the buffers menu will contain several commands, as submenus
of each buffer line.  If this is false, then there will be only one command:
select that buffer.")

(defvar buffers-menu-switch-to-buffer-function 'switch-to-buffer
  "*The function to call to select a buffer from the buffers menu.
`switch-to-buffer' is a good choice, as is `pop-to-buffer'.")


(defun buffer-menu-save-buffer (buffer)
  (save-excursion
    (set-buffer buffer)
    (save-buffer)))

(defun buffer-menu-write-file (buffer)
  (save-excursion
    (set-buffer buffer)
    (write-file (read-file-name
		 (format "Write %s to file: "
			 (buffer-name (current-buffer)))))))

(defsubst build-buffers-menu-internal (buffers)
  (let (name line)
    (mapcar
     (if complex-buffers-menu-p
	 #'(lambda (buffer)
	     (if (setq line (format-buffers-menu-line buffer))
		 (delq nil
		   (list line
		       (vector "Switch to Buffer"
			       (list buffers-menu-switch-to-buffer-function
				     (setq name (buffer-name buffer)))
			       t)
		       (if (eq buffers-menu-switch-to-buffer-function
			       'switch-to-buffer)
			   (vector "Switch to Buffer, Other Frame"
				   (list 'switch-to-buffer-other-frame
					 (setq name (buffer-name buffer)))
				   t)
			 nil)
		       (if (and (buffer-modified-p buffer)
				(buffer-file-name buffer))
			   (vector "Save Buffer"
				   (list 'buffer-menu-save-buffer name) t)
			     ["Save Buffer" nil nil]
			   )
		       (vector "Save As..."
			       (list 'buffer-menu-write-file name) t)
		       (vector "Delete Buffer" (list 'kill-buffer name) t)))))
       #'(lambda (buffer)
	   (if (setq line (format-buffers-menu-line buffer))
	       (vector line
		       (list buffers-menu-switch-to-buffer-function
			     (buffer-name buffer))
		       t))))
     buffers)))

(defun buffers-menu-filter (menu)
  "This is the menu filter for the top-level buffers \"Buffers\" menu.
It dynamically creates a list of buffers to use as the contents of the menu.
Only the most-recently-used few buffers will be listed on the menu, for
efficiency reasons.  You can control how many buffers will be shown by
setting `buffers-menu-max-size'.  You can control the text of the menu
items by redefining the function `format-buffers-menu-line'."
  (let ((buffers (buffer-list)))
    (and (integerp buffers-menu-max-size)
	 (> buffers-menu-max-size 1)
	 (> (length buffers) buffers-menu-max-size)
	 ;; shorten list of buffers
	 (setcdr (nthcdr buffers-menu-max-size buffers) nil))
      (setq buffers (delq nil (build-buffers-menu-internal buffers)))
      (append menu buffers)
      ))



;;; The Options menu

(defconst options-menu-saved-forms
  ;; This is really quite a kludge, but it gets the job done.
  (purecopy
   '(overwrite-mode			; #### - does this WORK???
     teach-extended-commands-p
     bar-cursor
     debug-on-error
     debug-on-quit
     get-frame-for-buffer-default-instance-limit
     temp-buffer-show-function
     complex-buffers-menu-p
     font-menu-ignore-scaled-fonts
     font-menu-this-frame-only-p
     buffers-menu-max-size
     case-fold-search
     case-replace
     zmacs-regions
     truncate-lines
     mouse-yank-at-point
     ;; We only save global settings since the others will belong to
     ;; objects which only exist during this session.
     `(set-default-toolbar-position
       ',(default-toolbar-position))
     `(add-spec-list-to-specifier
       top-toolbar-height
       ',(specifier-spec-list top-toolbar-height 'global))
     `(add-spec-list-to-specifier
       bottom-toolbar-height
       ',(specifier-spec-list bottom-toolbar-height 'global))
     `(add-spec-list-to-specifier
       left-toolbar-width
       ',(specifier-spec-list left-toolbar-width 'global))
     `(add-spec-list-to-specifier
       right-toolbar-width
       ',(specifier-spec-list right-toolbar-width 'global))
     `(add-spec-list-to-specifier
       scrollbar-width
       ',(specifier-spec-list scrollbar-width 'global))
     `(add-spec-list-to-specifier
       scrollbar-height
       ',(specifier-spec-list scrollbar-height 'global))
     `(add-spec-list-to-specifier
       modeline-shadow-thickness
       ',(specifier-spec-list modeline-shadow-thickness 'global))
     (if paren-mode
 	 `(progn (require 'paren) (paren-set-mode ',paren-mode)))
     (if (memq 'pending-delete-pre-hook pre-command-hook)
	 '(require 'pending-del))
     ;; Setting this in lisp conflicts with X resources.  Bad move.  --Stig 
     ;; (list 'set-face-font ''default (face-font-name 'default))
     ;; (list 'set-face-font ''modeline (face-font-name 'modeline))
     font-lock-auto-fontify
     font-lock-use-fonts
     font-lock-use-colors
     font-lock-use-maximal-decoration
     font-lock-mode-enable-list
     font-lock-mode-disable-list
     ;; #### - these structures are clearly broken.  There's no way to ever
     ;; un-require font-lock or fast-lock via the menus.  --Stig
     (if (featurep 'font-lock)
	 '(require 'font-lock))
     (if (featurep 'fast-lock)
	 '(require 'fast-lock))
     (if (and (boundp 'font-lock-mode-hook)
	      (memq 'turn-on-fast-lock font-lock-mode-hook))
	 '(add-hook 'font-lock-mode-hook 'turn-on-fast-lock)
       '(remove-hook 'font-lock-mode-hook 'turn-on-fast-lock))
     (cons 'progn
	   (apply 'nconc
		  (mapcar
		   #'(lambda (face)
		       (cons
			`(make-face ',face)
			(delq nil
			      (mapcar
			       #'(lambda (property)
				   (if (specifier-spec-list
					(face-property face property))
				       `(add-spec-list-to-specifier
					 (face-property ',face ',property)
					 ',(save-options-specifier-spec-list face property))))
			       built-in-face-specifiers))))
		   (face-list))))
     ))
  "The variables to save; or forms to evaluate to get forms to write out.")

(defun save-options-specifier-spec-list (face property)
  (if (not (or (eq property 'font) (eq property 'color)))
      (specifier-spec-list (face-property face property) 'global)
    (let* ((retlist (specifier-spec-list (face-property face property)
					 'global))
	   (entry (cdr (car retlist)))
	   item)
      (while entry
	(setq item (car entry))
	(if (eq property 'font)
	    (if (font-instance-p (cdr item))
		(setcdr item (font-instance-name (cdr item))))
	  (if (color-instance-p (cdr item))
	      (setcdr item (color-instance-name (cdr item)))))
	(setq entry (cdr entry)))
      retlist)))

(defvar save-options-file (concat "~" init-file-user "/.emacs")
	"File to save options into.")

(defun save-options-menu-settings ()
  "Saves the current settings of the `Options' menu to your `.emacs' file."
  (interactive)
  (let ((output-buffer (find-file-noselect
				(expand-file-name save-options-file)))
				output-marker)
    (save-excursion
      (set-buffer output-buffer)
      ;;
      ;; Find and delete the previously saved data, and position to write.
      ;;
      (goto-char (point-min))
      (if (re-search-forward "^;; Options Menu Settings *\n" nil 'move)
	  (let ((p (match-beginning 0)))
	    (goto-char p)
	    (or (re-search-forward
		 "^;; End of Options Menu Settings *\\(\n\\|\\'\\)"
		 nil t)
		(error "can't find END of saved state in .emacs"))
	    (delete-region p (match-end 0)))
	(goto-char (point-max))
	(insert "\n"))
      (setq output-marker (point-marker))

      ;; run with current-buffer unchanged so that variables are evaluated in
      ;; the current context, instead of in the context of the ".emacs" buffer.
      (let ((print-readably t)
	    (print-escape-newlines t)
	    (standard-output output-marker))
	(princ ";; Options Menu Settings\n")
	(princ ";; =====================\n")
	(princ "(cond\n")
	(princ " ((and (string-match \"XEmacs\" emacs-version)\n")
	(princ "       (boundp 'emacs-major-version)\n")
	(princ "       (= emacs-major-version 19)\n")
	(princ "       (>= emacs-minor-version 12))\n")
	(mapcar #'(lambda (var)
		    (princ "  ")
		    (if (symbolp var)
			(prin1 (list 'setq-default var
				     (let ((val (symbol-value var)))
				       (if (or (memq val '(t nil))
					       (not (symbolp val)))
					   val
					 (list 'quote val)))))
		      (setq var (eval var))
		      (cond ((eq (car-safe var) 'progn)
			     (while (setq var (cdr var))
			       (prin1 (car var))
			       (princ "\n")
			       (if (cdr var) (princ "  "))
			       ))
			    (var
			     (prin1 var))))
		    (if var (princ "\n")))
		options-menu-saved-forms)
	(princ "  ))\n")
	(princ ";; ============================\n")
	(princ ";; End of Options Menu Settings\n")
	))
    (set-marker output-marker nil)
    (save-excursion
      (set-buffer output-buffer)
      (save-buffer))
    ))


(set-menubar default-menubar)


;;; Popup menus.

(defconst default-popup-menu
  '("XEmacs Commands"
    ["Undo"		advertised-undo		t]
    ["Cut"		x-kill-primary-selection   t]
    ["Copy"		x-copy-primary-selection   t]
    ["Paste"		x-yank-clipboard-selection t]
    "-----"
    ["Select Block"	mark-paragraph 		t]
    ["Split Window"	(split-window)		t]
    ["Unsplit Window" 	delete-other-windows	t]
    ))

(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)

;; In an effort to avoid massive menu clutter, this mostly worthless menu is
;; superceded by any local popup menu...
(setq-default mode-popup-menu default-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.")

(defun popup-mode-menu ()
  "Pop up a menu of global and mode-specific commands.
The menu is computed by combining `global-popup-menu' and `mode-popup-menu'."
  (interactive "@_")
  (run-hooks 'activate-popup-menu-hook)
  (popup-menu
   (cond ((and global-popup-menu mode-popup-menu)
	  (check-menu-syntax mode-popup-menu)
	  (let ((title (car mode-popup-menu))
		(items (cdr mode-popup-menu)))
	    (append global-popup-menu
		    '("---" "---")
		    (if popup-menu-titles (list title))
		    (if popup-menu-titles '("---" "---"))
		    items)))
	 (t
	  (or mode-popup-menu
	      global-popup-menu
	      (error "No menu here."))))))

(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"
  ;; by Stig@hackvan.com
  (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))
    ))

(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)
(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"
;        ))


(provide 'x-menubar)

;;; x-menubar.el ends here.
