;;; mouse.el --- window system-independent mouse support
-;; Copyright (C) 1993, 1994, 1995, 1999 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1994, 1995, 1999, 2000 Free Software Foundation, Inc.
;; Maintainer: FSF
-;; Keywords: hardware
+;; Keywords: hardware, mouse
;; This file is part of GNU Emacs.
\f
;; Provide a mode-specific menu on a mouse button.
+(defun popup-menu (menu &optional position prefix)
+ "Popup the given menu and call the selected option.
+MENU can be a keymap, an easymenu-style menu or a list of keymaps as for
+`x-popup-menu'.
+POSITION can be a click event or ((XOFFSET YOFFSET) WINDOW) and defaults to
+ the current mouse position.
+PREFIX is the prefix argument (if any) to pass to the command."
+ (let* ((map (cond
+ ((keymapp menu) menu)
+ ((and (listp menu) (keymapp (car menu))) menu)
+ (t (let* ((map (easy-menu-create-menu (car menu) (cdr menu)))
+ (filter (when (symbolp map)
+ (plist-get (get map 'menu-pro) :filter))))
+ (if filter (funcall filter (symbol-function map)) map)))))
+ event cmd)
+ (unless position
+ (let ((mp (mouse-pixel-position)))
+ (setq position (list (list (cadr mp) (cddr mp)) (car mp)))))
+ ;; The looping behavior was taken from lmenu's popup-menu-popup
+ (while (and map (setq event
+ ;; map could be a prefix key, in which case
+ ;; we need to get its function cell
+ ;; definition.
+ (x-popup-menu position (indirect-function map))))
+ ;; Strangely x-popup-menu returns a list.
+ ;; mouse-major-mode-menu was using a weird:
+ ;; (key-binding (apply 'vector (append '(menu-bar) menu-prefix events)))
+ (setq cmd
+ (if (and (not (keymapp map)) (listp map))
+ ;; We were given a list of keymaps. Search them all
+ ;; in sequence until a first binding is found.
+ (let ((mouse-click (apply 'vector event))
+ binding)
+ (while (and map (null binding))
+ (setq binding (lookup-key (car map) mouse-click))
+ (if (numberp binding) ; `too long'
+ (setq binding nil))
+ (setq map (cdr map)))
+ binding)
+ ;; We were given a single keymap.
+ (lookup-key map (apply 'vector event))))
+ ;; Clear out echoing, which perhaps shows a prefix arg.
+ (message "")
+ ;; Maybe try again but with the submap.
+ (setq map (if (keymapp cmd) cmd)))
+ (when (functionp cmd)
+ (setq prefix-arg prefix)
+ ;; `setup-specified-language-environment', for instance,
+ ;; expects this to be set from a menu keymap.
+ (setq last-command-event (car (last event)))
+ ;; mouse-major-mode-menu was using `command-execute' instead.
+ (call-interactively cmd))))
+
+(defvar mouse-major-mode-menu-prefix) ; dynamically bound
+
(defun mouse-major-mode-menu (event prefix)
"Pop up a mode-specific menu of mouse commands.
Default to the Edit menu if the major mode doesn't define a menu."
;; the mode's commands may not make sense.
(interactive "@e\nP")
;; Let the mode update its menus first.
- (run-hooks 'activate-menubar-hook)
+ (run-hooks 'activate-menubar-hook 'menu-bar-update-hook)
(let* (;; This is where mouse-major-mode-menu-prefix
;; returns the prefix we should use (after menu-bar).
;; It is either nil or (SOME-SYMBOL).
;; Keymap from which to inherit; may be null.
(ancestor (mouse-major-mode-menu-1
(and (current-local-map)
- (lookup-key (current-local-map) [menu-bar]))))
+ (local-key-binding [menu-bar]))))
;; Make a keymap in which our last command leads to a menu or
;; default to the edit menu.
(newmap (if ancestor
;; Make our menu inherit from the desired keymap which we want
;; to display as the menu now.
(set-keymap-parent newmap ancestor))
- (setq result (x-popup-menu t (list newmap)))
- (if result
- (let ((command (key-binding
- (apply 'vector (append '(menu-bar)
- mouse-major-mode-menu-prefix
- result)))))
- ;; Clear out echoing, which perhaps shows a prefix arg.
- (message "")
- (if command
- (progn
- (setq prefix-arg prefix)
- (command-execute command)))))))
+ (popup-menu newmap event prefix)))
+
;; Compute and cache the equivalent keys in MENU and all its submenus.
;;;(defun mouse-major-mode-menu-compute-equiv-keys (menu)
menubar
(setq mouse-major-mode-menu-prefix (list (car submap)))
(lookup-key menubar (vector (car submap)))))))
+
+(defun mouse-popup-menubar (event prefix)
+ "Pops up a menu equiavlent to the menu bar a keyboard EVENT with PREFIX.
+The contents are the items that would be in the menu bar whether or
+not it is actually displayed."
+ (interactive "@e \nP")
+ (run-hooks 'activate-menubar-hook 'menu-bar-update-hook)
+ (let* ((local-menu (and (current-local-map)
+ (lookup-key (current-local-map) [menu-bar])))
+ (global-menu (lookup-key global-map [menu-bar]))
+ ;; If a keymap doesn't have a prompt string (a lazy
+ ;; programmer didn't bother to provide one), create it and
+ ;; insert it into the keymap; each keymap gets its own
+ ;; prompt. This is required for non-toolkit versions to
+ ;; display non-empty menu pane names.
+ (minor-mode-menus
+ (mapcar
+ (function
+ (lambda (menu)
+ (let* ((minor-mode (car menu))
+ (menu (cdr menu))
+ (title-or-map (cadr menu)))
+ (or (stringp title-or-map)
+ (setq menu
+ (cons 'keymap
+ (cons (concat
+ (capitalize (subst-char-in-string
+ ?- ?\ (symbol-name
+ minor-mode)))
+ " Menu")
+ (cdr menu)))))
+ menu)))
+ (minor-mode-key-binding [menu-bar])))
+ (local-title-or-map (and local-menu (cadr local-menu)))
+ (global-title-or-map (cadr global-menu)))
+ (or (null local-menu)
+ (stringp local-title-or-map)
+ (setq local-menu (cons 'keymap
+ (cons (concat mode-name " Mode Menu")
+ (cdr local-menu)))))
+ (or (stringp global-title-or-map)
+ (setq global-menu (cons 'keymap
+ (cons "Global Menu"
+ (cdr global-menu)))))
+ ;; Supplying the list is faster than making a new map.
+ (popup-menu (append (list global-menu)
+ (if local-menu
+ (list local-menu))
+ minor-mode-menus)
+ event prefix)))
+
+(defun mouse-popup-menubar-stuff (event prefix)
+ "Popup a menu like either `mouse-major-mode-menu' or `mouse-popup-menubar'.
+Use the former if the menu bar is showing, otherwise the latter."
+ (interactive "@e \nP")
+ (if (zerop (assoc-default 'menu-bar-lines (frame-parameters) 'eq 0))
+ (mouse-popup-menubar event prefix)
+ (mouse-major-mode-menu event prefix)))
\f
;; Commands that operate on windows.
MODE-LINE-P non-nil means a mode line is dragged."
;; Give temporary modes such as isearch a chance to turn off.
(run-hooks 'mouse-leave-buffer-hook)
- (let ((done nil)
- (echo-keystrokes 0)
- (start-event-frame (window-frame (car (car (cdr start-event)))))
- (start-event-window (car (car (cdr start-event))))
- (start-nwindows (count-windows t))
- (old-selected-window (selected-window))
- should-enlarge-minibuffer
- event mouse minibuffer y top bot edges wconfig params growth)
- (setq params (frame-parameters))
- (setq minibuffer (cdr (assq 'minibuffer params)))
+ (let* ((done nil)
+ (echo-keystrokes 0)
+ (start (event-start start-event))
+ (start-event-window (posn-window start))
+ (start-event-frame (window-frame start-event-window))
+ (start-nwindows (count-windows t))
+ (old-selected-window (selected-window))
+ (minibuffer (frame-parameter nil 'minibuffer))
+ should-enlarge-minibuffer event mouse y top bot edges wconfig growth)
(track-mouse
(progn
;; enlarge-window only works on the selected window, so
;; we must select the window where the start event originated.
;; unwind-protect will restore the old selected window later.
(select-window start-event-window)
+
;; if this is the bottommost ordinary window, then to
;; move its modeline the minibuffer must be enlarged.
(setq should-enlarge-minibuffer
(not (one-window-p t))
(= (nth 1 (window-edges minibuffer))
(nth 3 (window-edges)))))
+
;; loop reading events and sampling the position of
;; the mouse.
(while (not done)
(setq event (read-event)
mouse (mouse-position))
+
;; do nothing if
;; - there is a switch-frame event.
;; - the mouse isn't in the frame that we started in
;; unknown event.
(cond ((integerp event)
(setq done t))
+
((eq (car event) 'switch-frame)
nil)
- ((not (memq (car event)
- '(mouse-movement scroll-bar-movement)))
- (if (consp event)
- (setq unread-command-events
- (cons event unread-command-events)))
+
+ ((not (memq (car event) '(mouse-movement scroll-bar-movement)))
+ (when (consp event)
+ (push event unread-command-events))
(setq done t))
+
((not (eq (car mouse) start-event-frame))
nil)
+
((null (car (cdr mouse)))
nil)
+
(t
(setq y (cdr (cdr mouse))
edges (window-edges)
(when (< (- y top -1) window-min-height)
(setq y (+ top window-min-height -1)))
(setq growth (- y bot -1)))
- (t
- (when (< (- bot y -1) window-min-height)
- (setq y (- bot window-min-height -1)))
- (setq growth (- top y -1))))
+ (t ; header line
+ (when (< (- bot y) window-min-height)
+ (setq y (- bot window-min-height)))
+ ;; The window's top includes the header line!
+ (setq growth (- top y))))
(setq wconfig (current-window-configuration))
;; Check for an error case.
- (if (and (/= growth 0)
- (not minibuffer)
- (one-window-p t))
- (error "Attempt to resize sole window"))
+ (when (and (/= growth 0)
+ (not minibuffer)
+ (one-window-p t))
+ (error "Attempt to resize sole window"))
;; grow/shrink minibuffer?
(if should-enlarge-minibuffer
(enlarge-window (- growth))
(select-window start-event-window))
;; no. grow/shrink the selected window
- ;; (message "growth = %d" growth)
+ ;(message "growth = %d" growth)
(enlarge-window growth))
;; if this window's growth caused another
;; the minibuffer. minibuffer size changes
;; can cause all windows to shrink... no way
;; around it.
- (if (or (/= start-nwindows (count-windows t))
- (and (not should-enlarge-minibuffer)
- mode-line-p
- (/= top (nth 1 (window-edges)))))
- (set-window-configuration wconfig)))))))))
+ (when (or (/= start-nwindows (count-windows t))
+ (and (not should-enlarge-minibuffer)
+ mode-line-p
+ (/= top (nth 1 (window-edges)))))
+ (set-window-configuration wconfig)))))))))
(defun mouse-drag-mode-line (start-event)
"Change the height of a window by dragging on the mode line."
(mouse-drag-mode-line-1 start-event t))
(defun mouse-drag-header-line (start-event)
- "Change the height of a window by dragging on the header line."
+ "Change the height of a window by dragging on the header line.
+Windows whose header-lines are at the top of the frame cannot be
+resized by dragging their header-line."
(interactive "e")
- (mouse-drag-mode-line-1 start-event nil))
+ ;; Changing the window's size by dragging its header-line when the
+ ;; header-line is at the top of the frame is somewhat strange,
+ ;; because the header-line doesn't move, so don't do it.
+ (let* ((start (event-start start-event))
+ (window (posn-window start))
+ (frame (window-frame window))
+ (first-window (frame-first-window frame)))
+ (when (or (eq window first-window)
+ (= (nth 1 (window-edges window))
+ (nth 1 (window-edges first-window))))
+ (error "Cannot move header-line at the top of the frame"))
+ (mouse-drag-mode-line-1 start-event nil)))
\f
(defun mouse-drag-vertical-line (start-event)
(if (not (eq system-type 'ms-dos))
(global-set-key [S-down-mouse-1] 'mouse-set-font))
;; C-down-mouse-2 is bound in facemenu.el.
-(global-set-key [C-down-mouse-3] 'mouse-major-mode-menu)
+(global-set-key [C-down-mouse-3] 'mouse-popup-menubar-stuff)
;; Replaced with dragging mouse-1
;; (global-set-key [S-mouse-1] 'mouse-set-mark)
+;; Binding mouse-1 to mouse-select-window when on mode-, header-, or
+;; vertical-line prevents Emacs from signaling an error when the mouse
+;; button is released after dragging these lines, on non-toolkit
+;; versions.
(global-set-key [mode-line mouse-1] 'mouse-select-window)
(global-set-key [mode-line drag-mouse-1] 'mouse-select-window)
(global-set-key [mode-line down-mouse-1] 'mouse-drag-mode-line)
(global-set-key [header-line down-mouse-1] 'mouse-drag-header-line)
+(global-set-key [header-line mouse-1] 'mouse-select-window)
(global-set-key [mode-line mouse-2] 'mouse-delete-other-windows)
(global-set-key [mode-line mouse-3] 'mouse-delete-window)
(global-set-key [mode-line C-mouse-2] 'mouse-split-window-horizontally)