-;;; mouse.el --- window system-independent mouse support
+;;; mouse.el --- window system-independent mouse support -*- lexical-binding: t -*-
-;; Copyright (C) 1993-1995, 1999-2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1995, 1999-2012 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: hardware, mouse
If value is an integer, the time elapsed between pressing and
releasing the mouse button determines whether to follow the link
or perform the normal Mouse-1 action (typically set point).
-The absolute numeric value specifices the maximum duration of a
+The absolute numeric value specifies the maximum duration of a
\"short click\" in milliseconds. A positive value means that a
short click follows the link, and a longer click performs the
normal action. A negative value gives the opposite behavior.
"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.
+The menu is shown at the place where POSITION specifies. About
+the form of POSITION, see `popup-menu-normalize-position'.
PREFIX is the prefix argument (if any) to pass to the command."
(let* ((map (cond
((keymapp menu) menu)
(filter (when (symbolp map)
(plist-get (get map 'menu-prop) :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)))))
+ event cmd
+ (position (popup-menu-normalize-position position)))
;; 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
binding)
(while (and map (null binding))
(setq binding (lookup-key (car map) mouse-click))
- (if (numberp binding) ; `too long'
+ (if (numberp binding) ; `too long'
(setq binding nil))
(setq map (cdr map)))
binding)
;; mouse-major-mode-menu was using `command-execute' instead.
(call-interactively cmd))))
+(defun popup-menu-normalize-position (position)
+ "Convert the POSITION to the form which `popup-menu' expects internally.
+POSITION can an event, a posn- value, a value having
+form ((XOFFSET YOFFSET) WINDOW), or nil.
+If nil, the current mouse position is used."
+ (pcase position
+ ;; nil -> mouse cursor position
+ (`nil
+ (let ((mp (mouse-pixel-position)))
+ (list (list (cadr mp) (cddr mp)) (car mp))))
+ ;; Value returned from `event-end' or `posn-at-point'.
+ ((pred posnp)
+ (let ((xy (posn-x-y position)))
+ (list (list (car xy) (cdr xy))
+ (posn-window position))))
+ ;; Event.
+ ((pred eventp)
+ (popup-menu-normalize-position (event-end position)))
+ (t position)))
+
(defun minor-mode-menu-from-indicator (indicator)
"Show menu for minor mode specified by INDICATOR.
Interactively, INDICATOR is read using completion.
(newmap (if ancestor
(make-sparse-keymap (concat (format-mode-line mode-name)
" Mode"))
- menu-bar-edit-menu))
- uniq)
+ menu-bar-edit-menu)))
(if ancestor
(set-keymap-parent newmap ancestor))
newmap))
(let ((w (posn-window (event-start event))))
(and (window-minibuffer-p w)
(not (minibuffer-window-active-p w))
- (error "Minibuffer window is not active")))
+ (user-error "Minibuffer window is not active")))
;; Give temporary modes such as isearch a chance to turn off.
(run-hooks 'mouse-leave-buffer-hook))
(split-window-horizontally
(min (max new-width first-col) last-col))))))
-(defun mouse-drag-window-above (window)
- "Return the (or a) window directly above WINDOW.
-That means one whose bottom edge is at the same height as WINDOW's top edge."
- (let ((start-top (nth 1 (window-edges window)))
- (start-left (nth 0 (window-edges window)))
- (start-right (nth 2 (window-edges window)))
- (start-window window)
- above-window)
- (setq window (previous-window window 0))
- (while (and (not above-window) (not (eq window start-window)))
- (let ((left (nth 0 (window-edges window)))
- (right (nth 2 (window-edges window))))
- (when (and (= (+ (window-height window) (nth 1 (window-edges window)))
- start-top)
- (or (and (<= left start-left) (<= start-right right))
- (and (<= start-left left) (<= left start-right))
- (and (<= start-left right) (<= right start-right))))
- (setq above-window window)))
- (setq window (previous-window window)))
- above-window))
-
-(defun mouse-drag-move-window-bottom (window growth)
- "Move the bottom of WINDOW up or down by GROWTH lines.
-Move it down if GROWTH is positive, or up if GROWTH is negative.
-If this would make WINDOW too short,
-shrink the window or windows above it to make room."
- (condition-case nil
- (adjust-window-trailing-edge window growth nil)
- (error nil)))
-
-(defsubst mouse-drag-move-window-top (window growth)
- "Move the top of WINDOW up or down by GROWTH lines.
-Move it down if GROWTH is positive, or up if GROWTH is negative.
-If this would make WINDOW too short, shrink the window or windows
-above it to make room."
- ;; Moving the top of WINDOW is actually moving the bottom of the
- ;; window above.
- (let ((window-above (mouse-drag-window-above window)))
- (and window-above
- (mouse-drag-move-window-bottom window-above (- growth)))))
-
-(defun mouse-drag-mode-line-1 (start-event mode-line-p)
- "Change the height of a window by dragging on the mode or header line.
-START-EVENT is the starting mouse-event of the drag action.
-MODE-LINE-P non-nil means dragging a mode line; nil means a header line."
+;; `mouse-drag-line' is now the common routine for handling all line
+;; dragging events combining the earlier `mouse-drag-mode-line-1' and
+;; `mouse-drag-vertical-line'. It should improve the behavior of line
+;; dragging wrt Emacs 23 as follows:
+
+;; (1) Gratuitous error messages and restrictions have been (hopefully)
+;; removed. (The help-echo that dragging the mode-line can resize a
+;; one-window-frame's window will still show through via bindings.el.)
+
+;; (2) No gratuitous selection of other windows should happen. (This
+;; has not been completely fixed for mouse-autoselected windows yet.)
+
+;; (3) Mouse clicks below a scroll-bar should pass through via unread
+;; command events.
+
+;; Note that `window-in-direction' replaces `mouse-drag-window-above'
+;; and `mouse-drag-vertical-line-rightward-window' with Emacs 24.1.
+
+(defun mouse-drag-line (start-event line)
+ "Drag a mode line, header line, or vertical line with the mouse.
+START-EVENT is the starting mouse-event of the drag action. LINE
+must be one of the symbols `header', `mode', or `vertical'."
;; Give temporary modes such as isearch a chance to turn off.
(run-hooks 'mouse-leave-buffer-hook)
- (let* ((done nil)
- (echo-keystrokes 0)
+ (let* ((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))
+ (window (posn-window start))
+ (frame (window-frame window))
+ (minibuffer-window (minibuffer-window frame))
(on-link (and mouse-1-click-follows-link
- (or mouse-1-click-in-non-selected-windows
- (eq (posn-window start) (selected-window)))
- (mouse-on-link-p start)))
- (minibuffer (frame-parameter nil 'minibuffer))
- should-enlarge-minibuffer event mouse y top bot edges wconfig growth)
+ (mouse-on-link-p start)))
+ (side (and (eq line 'vertical)
+ (or (cdr (assq 'vertical-scroll-bars
+ (frame-parameters frame)))
+ 'right)))
+ (draggable t)
+ event position growth dragged)
+ (cond
+ ((eq line 'header)
+ ;; Check whether header-line can be dragged at all.
+ (if (window-at-side-p window 'top)
+ (setq draggable nil)
+ (setq window (window-in-direction 'above window t))))
+ ((eq line 'mode)
+ ;; Check whether mode-line can be dragged at all.
+ (and (window-at-side-p window 'bottom)
+ ;; Allow resizing the minibuffer window if it's on the same
+ ;; frame as and immediately below the clicked window, and
+ ;; it's active or `resize-mini-windows' is nil.
+ (not (and (eq (window-frame minibuffer-window) frame)
+ (= (nth 1 (window-edges minibuffer-window))
+ (nth 3 (window-edges window)))
+ (or (not resize-mini-windows)
+ (eq minibuffer-window
+ (active-minibuffer-window)))))
+ (setq draggable nil)))
+ ((eq line 'vertical)
+ ;; Get the window to adjust for the vertical case. If the
+ ;; scroll bar is on the window's right or there's no scroll bar
+ ;; at all, adjust the window where the start-event occurred. If
+ ;; the scroll bar is on the start-event window's left, adjust
+ ;; the window on the left of it.
+ (unless (eq side 'right)
+ (setq window (window-in-direction 'left window t)))))
+
+ ;; Start tracking.
(track-mouse
- (progn
- ;; if this is the bottommost ordinary window, then to
- ;; move its modeline the minibuffer must be enlarged.
- (setq should-enlarge-minibuffer
- (and minibuffer
- mode-line-p
- (not (one-window-p t))
- (= (nth 1 (window-edges minibuffer))
- (nth 3 (window-edges start-event-window)))))
-
- ;; 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
- ;; - the mouse isn't in any Emacs frame
- ;; drag if
- ;; - there is a mouse-movement event
- ;; - there is a scroll-bar-movement event
- ;; (same as mouse movement for our purposes)
- ;; quit if
- ;; - there is a keyboard event or some other unknown event.
- (cond ((not (consp event))
- (setq done t))
-
- ((memq (car event) '(switch-frame select-window))
- nil)
-
- ((not (memq (car event) '(mouse-movement scroll-bar-movement)))
- (when (consp event)
- ;; Do not unread a drag-mouse-1 event since it will cause the
- ;; selection of the window above when dragging the modeline
- ;; above the selected window.
- (unless (eq (car event) 'drag-mouse-1)
- (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 start-event-window)
- top (nth 1 edges)
- bot (nth 3 edges))
-
- ;; compute size change needed
- (cond (mode-line-p
- (setq growth (- y bot -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.
- (when (and (/= growth 0)
- (not minibuffer)
- (one-window-p t))
- (error "Attempt to resize sole window"))
-
- ;; If we ever move, make sure we don't mistakenly treat
- ;; some unexpected `mouse-1' final event as a sign that
- ;; this whole drag was nothing more than a click.
- (if (/= growth 0) (setq on-link nil))
-
- ;; grow/shrink minibuffer?
- (if should-enlarge-minibuffer
- (unless resize-mini-windows
- (mouse-drag-move-window-bottom start-event-window growth))
- ;; no. grow/shrink the selected window
- ;(message "growth = %d" growth)
- (if mode-line-p
- (mouse-drag-move-window-bottom start-event-window growth)
- (mouse-drag-move-window-top start-event-window growth)))
-
- ;; if this window's growth caused another
- ;; window to be deleted because it was too
- ;; short, rescind the change.
- ;;
- ;; if size change caused space to be stolen
- ;; from a window above this one, rescind the
- ;; change, but only if we didn't grow/shrink
- ;; the minibuffer. minibuffer size changes
- ;; can cause all windows to shrink... no way
- ;; around it.
- (when (or (/= start-nwindows (count-windows t))
- (and (not should-enlarge-minibuffer)
- (> growth 0)
- mode-line-p
- (/= top
- (nth 1 (window-edges
- ;; Choose right window.
- start-event-window)))))
- (set-window-configuration wconfig)))))
-
- ;; Presumably if this was just a click, the last event should
- ;; be `mouse-1', whereas if this did move the mouse, it should be
- ;; a `drag-mouse-1'. In any case `on-link' would have been nulled
- ;; above if there had been any significant mouse movement.
- (when (and on-link (eq 'mouse-1 (car-safe event)))
- ;; If mouse-2 has never been done by the user, it doesn't
- ;; have the necessary property to be interpreted correctly.
- (put 'mouse-2 'event-kind 'mouse-click)
- (push (cons 'mouse-2 (cdr event)) unread-command-events))))))
+ ;; Loop reading events and sampling the position of the mouse.
+ (while draggable
+ (setq event (read-event))
+ (setq position (mouse-position))
+ ;; Do nothing if
+ ;; - there is a switch-frame event.
+ ;; - the mouse isn't in the frame that we started in
+ ;; - the mouse isn't in any Emacs frame
+ ;; Drag if
+ ;; - there is a mouse-movement event
+ ;; - there is a scroll-bar-movement event (Why? -- cyd)
+ ;; (same as mouse movement for our purposes)
+ ;; Quit if
+ ;; - there is a keyboard event or some other unknown event.
+ (cond
+ ((not (consp event))
+ (setq draggable nil))
+ ((memq (car event) '(switch-frame select-window))
+ nil)
+ ((not (memq (car event) '(mouse-movement scroll-bar-movement)))
+ (when (consp event)
+ ;; Do not unread a drag-mouse-1 event to avoid selecting
+ ;; some other window. For vertical line dragging do not
+ ;; unread mouse-1 events either (but only if we dragged at
+ ;; least once to allow mouse-1 clicks get through.
+ (unless (and dragged
+ (if (eq line 'vertical)
+ (memq (car event) '(drag-mouse-1 mouse-1))
+ (eq (car event) 'drag-mouse-1)))
+ (push event unread-command-events)))
+ (setq draggable nil))
+ ((or (not (eq (car position) frame))
+ (null (car (cdr position))))
+ nil)
+ ((eq line 'vertical)
+ ;; Drag vertical divider.
+ (setq growth (- (cadr position)
+ (if (eq side 'right) 0 2)
+ (nth 2 (window-edges window))
+ -1))
+ (unless (zerop growth)
+ (setq dragged t))
+ (adjust-window-trailing-edge window growth t))
+ (draggable
+ ;; Drag horizontal divider.
+ (setq growth
+ (if (eq line 'mode)
+ (- (cddr position) (nth 3 (window-edges window)) -1)
+ ;; The window's top includes the header line!
+ (- (nth 3 (window-edges window)) (cddr position))))
+ (unless (zerop growth)
+ (setq dragged t))
+ (adjust-window-trailing-edge window (if (eq line 'mode)
+ growth
+ (- growth)))))))
+ ;; Process the terminating event.
+ (when (and (mouse-event-p event) on-link (not dragged)
+ (mouse--remap-link-click-p start-event event))
+ ;; If mouse-2 has never been done by the user, it doesn't have
+ ;; the necessary property to be interpreted correctly.
+ (put 'mouse-2 'event-kind 'mouse-click)
+ (setcar event 'mouse-2))
+ (push event unread-command-events)))
(defun mouse-drag-mode-line (start-event)
"Change the height of a window by dragging on the mode line."
(interactive "e")
- (mouse-drag-mode-line-1 start-event t))
+ (mouse-drag-line start-event 'mode))
(defun mouse-drag-header-line (start-event)
- "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."
+ "Change the height of a window by dragging on the header line."
(interactive "e")
- ;; 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)))
- (unless (or (eq window first-window)
- (= (nth 1 (window-edges window))
- (nth 1 (window-edges first-window))))
- (mouse-drag-mode-line-1 start-event nil))))
-
-\f
-(defun mouse-drag-vertical-line-rightward-window (window)
- "Return a window that is immediately to the right of WINDOW, or nil."
- (let ((bottom (nth 3 (window-inside-edges window)))
- (left (nth 0 (window-inside-edges window)))
- best best-right
- (try (previous-window window)))
- (while (not (eq try window))
- (let ((try-top (nth 1 (window-inside-edges try)))
- (try-bottom (nth 3 (window-inside-edges try)))
- (try-right (nth 2 (window-inside-edges try))))
- (if (and (< try-top bottom)
- (>= try-bottom bottom)
- (< try-right left)
- (or (null best-right) (> try-right best-right)))
- (setq best-right try-right best try)))
- (setq try (previous-window try)))
- best))
+ (mouse-drag-line start-event 'header))
(defun mouse-drag-vertical-line (start-event)
"Change the width of a window by dragging on the vertical line."
(interactive "e")
- ;; 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))))
- event mouse x left right edges growth
- (which-side
- (or (cdr (assq 'vertical-scroll-bars (frame-parameters start-event-frame)))
- 'right)))
- (cond
- ((one-window-p t)
- (error "Attempt to resize sole ordinary window"))
- ((and (eq which-side 'right)
- (>= (nth 2 (window-inside-edges start-event-window))
- (frame-width start-event-frame)))
- (error "Attempt to drag rightmost scrollbar"))
- ((and (eq which-side 'left)
- (= (nth 0 (window-inside-edges start-event-window)) 0))
- (error "Attempt to drag leftmost scrollbar")))
- (track-mouse
- (progn
- ;; 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
- ;; - the mouse isn't in any Emacs frame
- ;; drag if
- ;; - there is a mouse-movement event
- ;; - there is a scroll-bar-movement event
- ;; (same as mouse movement for our purposes)
- ;; quit if
- ;; - there is a keyboard event or some other unknown event
- ;; unknown event.
- (cond ((integerp event)
- (setq done t))
- ((memq (car event) '(switch-frame select-window))
- nil)
- ((not (memq (car event)
- '(mouse-movement scroll-bar-movement)))
- (if (consp event)
- (setq unread-command-events
- (cons event unread-command-events)))
- (setq done t))
- ((not (eq (car mouse) start-event-frame))
- nil)
- ((null (car (cdr mouse)))
- nil)
- (t
- (let ((window
- ;; If the scroll bar is on the window's left,
- ;; adjust the window on the left.
- (if (eq which-side 'right)
- start-event-window
- (mouse-drag-vertical-line-rightward-window
- start-event-window))))
- (setq x (- (car (cdr mouse))
- (if (eq which-side 'right) 0 2))
- edges (window-edges window)
- left (nth 0 edges)
- right (nth 2 edges))
- ;; scale back a move that would make the
- ;; window too thin.
- (if (< (- x left -1) window-min-width)
- (setq x (+ left window-min-width -1)))
- ;; compute size change needed
- (setq growth (- x right -1))
- (condition-case nil
- (adjust-window-trailing-edge window growth t)
- (error nil))))))))))
+ (mouse-drag-line start-event 'vertical))
\f
(defun mouse-set-point (event)
"Move point to the position clicked on with the mouse.
(mouse-minibuffer-check start-event)
(setq mouse-selection-click-count-buffer (current-buffer))
(deactivate-mark)
- (let* ((original-window (selected-window))
+ (let* ((scroll-margin 0) ; Avoid margin scrolling (Bug#9541).
+ (original-window (selected-window))
;; We've recorded what we needed from the current buffer and
;; window, now let's jump to the place of the event, where things
;; are happening.
;; Don't count the mode line.
(1- (nth 3 bounds))))
(on-link (and mouse-1-click-follows-link
- (or mouse-1-click-in-non-selected-windows
- (eq start-window original-window))
;; Use start-point before the intangibility
- ;; treatment, in case we click on a link inside an
+ ;; treatment, in case we click on a link inside
;; intangible text.
(mouse-on-link-p start-posn)))
(click-count (1- (event-click-count start-event)))
(= click-count 1)))
;; Suppress automatic hscrolling, because that is a nuisance
;; when setting point near the right fringe (but see below).
- (automatic-hscrolling-saved automatic-hscrolling)
- (automatic-hscrolling nil)
- event end end-point)
+ (auto-hscroll-mode-saved auto-hscroll-mode)
+ (auto-hscroll-mode nil)
+ moved-off-start event end end-point)
(setq mouse-selection-click-count click-count)
;; In case the down click is in the middle of some intangible text,
;; Automatic hscrolling did not occur during the call to
;; `read-event'; but if the user subsequently drags the
;; mouse, go ahead and hscroll.
- (let ((automatic-hscrolling automatic-hscrolling-saved))
+ (let ((auto-hscroll-mode auto-hscroll-mode-saved))
(redisplay))
(setq end (event-end event)
end-point (posn-point end))
+ ;; Note whether the mouse has left the starting position.
+ (unless (eq end-point start-point)
+ (setq moved-off-start t))
(if (and (eq (posn-window end) start-window)
(integer-or-marker-p end-point))
(mouse--drag-set-mark-and-point start-point
(let (deactivate-mark)
(copy-region-as-kill (mark) (point)))))
- ;; If point hasn't moved, run the binding of the
- ;; terminating up-event.
+ ;; Otherwise, run binding of terminating up-event.
(if do-multi-click
(goto-char start-point)
- (deactivate-mark))
+ (deactivate-mark)
+ (unless moved-off-start
+ (pop-mark)))
+
(when (and (functionp fun)
(= start-hscroll (window-hscroll start-window))
;; Don't run the up-event handler if the window
(defun mouse-yank-primary (click)
"Insert the primary selection at the position clicked on.
-Move point to the end of the inserted text.
-If `mouse-yank-at-point' is non-nil, insert at point
+Move point to the end of the inserted text, and set mark at
+beginning. If `mouse-yank-at-point' is non-nil, insert at point
regardless of where you click."
(interactive "e")
;; Give temporary modes such as isearch a chance to turn off.
;; FIXME: What about xterm-mouse-mode etc.?
(t
(x-get-selection 'PRIMARY)))))
- (if primary
- (insert primary)
- (error "No selection is available"))))
+ (unless primary
+ (error "No selection is available"))
+ (push-mark (point))
+ (insert primary)))
(defun mouse-kill-ring-save (click)
"Copy the region between point and the mouse click in the kill ring.
(choice
;; Either choice == 'x-select-font, or choice is a
;; symbol whose name is a font.
- (buffer-face-mode-invoke (font-face-attributes
- (if (eq choice 'x-select-font)
- (x-select-font)
- (symbol-name choice)))
- t
- (called-interactively-p 'interactive))))))))
+ (let ((font (if (eq choice 'x-select-font)
+ (x-select-font)
+ (symbol-name choice))))
+ (buffer-face-mode-invoke
+ (if (fontp font 'font-spec)
+ (list :font font)
+ (font-face-attributes font))
+ t (called-interactively-p 'interactive)))))))))
\f
;;; Bindings for mouse commands.
HCoop / bpt / emacs.git / blobdiff