Commit fbd5cc6c authored by Stefan Monnier's avatar Stefan Monnier

* lisp/mouse.el: Use the normal toplevel loop while dragging.

(mouse-set-point): Handle multi-clicks.
(mouse-set-region): Handle multi-clicks for drags.
(mouse-drag-region): Update call accordingly.
(mouse-drag-track): Remove `do-mouse-drag-region-post-process' hack.
Use the normal event loop instead of a local while/read-event loop.
(global-map): Remove redundant bindings for double/triple-mouse-1.
* lisp/xt-mouse.el (xterm-mouse-translate-1): Only process one event at a time.
Generate synthetic down events when the protocol only sends up events.
(xterm-mouse-last): Remove.
(xterm-mouse--read-event-sequence-1000): Use xterm-mouse-last-down
terminal parameter instead.
(xterm-mouse--set-click-count): New function.
(xterm-mouse-event): Detect/generate double/triple clicks.
* lisp/reveal.el (reveal-close-old-overlays): Don't close while dragging.
parent 80a78d23
2014-05-11 Stefan Monnier <monnier@iro.umontreal.ca>
* mouse.el: Use the normal toplevel loop while dragging.
(mouse-set-point): Handle multi-clicks.
(mouse-set-region): Handle multi-clicks for drags.
(mouse-drag-region): Update call accordingly.
(mouse-drag-track): Remove `do-mouse-drag-region-post-process' hack.
Use the normal event loop instead of a local while/read-event loop.
(global-map): Remove redundant bindings for double/triple-mouse-1.
* xt-mouse.el (xterm-mouse-translate-1): Only process one event at a time.
Generate synthetic down events when the protocol only sends up events.
(xterm-mouse-last): Remove.
(xterm-mouse--read-event-sequence-1000): Use xterm-mouse-last-down
terminal parameter instead.
(xterm-mouse--set-click-count): New function.
(xterm-mouse-event): Detect/generate double/triple clicks.
* reveal.el (reveal-close-old-overlays): Don't close while dragging.
* info.el (Info-quoted): New face.
(Info-mode-font-lock-keywords): New var.
(Info-mode): Use it.
......
......@@ -514,14 +514,18 @@ must be one of the symbols `header', `mode', or `vertical'."
(interactive "e")
(mouse-drag-line start-event 'vertical))
(defun mouse-set-point (event)
(defun mouse-set-point (event &optional promote-to-region)
"Move point to the position clicked on with the mouse.
This should be bound to a mouse click event type."
(interactive "e")
This should be bound to a mouse click event type.
If PROMOTE-TO-REGION is non-nil and event is a multiple-click,
select the corresponding element around point."
(interactive "e\np")
(mouse-minibuffer-check event)
;; Use event-end in case called from mouse-drag-region.
;; If EVENT is a click, event-end and event-start give same value.
(posn-set-point (event-end event)))
(if (and promote-to-region (> (event-click-count event) 1))
(mouse-set-region event)
;; Use event-end in case called from mouse-drag-region.
;; If EVENT is a click, event-end and event-start give same value.
(posn-set-point (event-end event))))
(defvar mouse-last-region-beg nil)
(defvar mouse-last-region-end nil)
......@@ -534,6 +538,8 @@ This should be bound to a mouse click event type."
(eq mouse-last-region-end (region-end))
(eq mouse-last-region-tick (buffer-modified-tick))))
(defvar mouse--drag-start-event nil)
(defun mouse-set-region (click)
"Set the region to the text dragged over, and copy to kill ring.
This should be bound to a mouse drag event.
......@@ -543,7 +549,22 @@ command alters the kill ring or not."
(mouse-minibuffer-check click)
(select-window (posn-window (event-start click)))
(let ((beg (posn-point (event-start click)))
(end (posn-point (event-end click))))
(end (posn-point (event-end click)))
(click-count (event-click-count click)))
(let ((drag-start (terminal-parameter nil 'mouse-drag-start)))
;; Drag events don't come with a click count, sadly, so we hack
;; our way around this problem by remembering the start-event in
;; `mouse-drag-start' and fetching the click-count from there.
(when drag-start
(when (and (<= click-count 1)
(equal beg (posn-point (event-start drag-start))))
(setq click-count (event-click-count drag-start)))
(setf (terminal-parameter nil 'mouse-drag-start) nil)))
(when (and (integerp beg) (integerp end))
(let ((range (mouse-start-end beg end (1- click-count))))
(if (< end beg)
(setq end (nth 0 range) beg (nth 1 range))
(setq beg (nth 0 range) end (nth 1 range)))))
(and mouse-drag-copy-region (integerp beg) (integerp end)
;; Don't set this-command to `kill-region', so a following
;; C-w won't double the text in the kill ring. Ignore
......@@ -637,13 +658,11 @@ Upon exit, point is at the far edge of the newly visible text."
Highlight the drag area as you move the mouse.
This must be bound to a button-down mouse event.
In Transient Mark mode, the highlighting remains as long as the mark
remains active. Otherwise, it remains until the next input event.
If the click is in the echo area, display the `*Messages*' buffer."
remains active. Otherwise, it remains until the next input event."
(interactive "e")
;; Give temporary modes such as isearch a chance to turn off.
(run-hooks 'mouse-leave-buffer-hook)
(mouse-drag-track start-event t))
(mouse-drag-track start-event))
(defun mouse-posn-property (pos property)
......@@ -747,12 +766,9 @@ at the same position."
"mouse-1" (substring msg 7)))))))
msg)
(defun mouse-drag-track (start-event &optional
do-mouse-drag-region-post-process)
(defun mouse-drag-track (start-event)
"Track mouse drags by highlighting area between point and cursor.
The region will be defined with mark and point.
DO-MOUSE-DRAG-REGION-POST-PROCESS should only be used by
`mouse-drag-region'."
The region will be defined with mark and point."
(mouse-minibuffer-check start-event)
(setq mouse-selection-click-count-buffer (current-buffer))
(deactivate-mark)
......@@ -765,8 +781,6 @@ DO-MOUSE-DRAG-REGION-POST-PROCESS should only be used by
(start-posn (event-start start-event))
(start-point (posn-point start-posn))
(start-window (posn-window start-posn))
(start-window-start (window-start start-window))
(start-hscroll (window-hscroll start-window))
(bounds (window-edges start-window))
(make-cursor-line-fully-visible nil)
(top (nth 1 bounds))
......@@ -777,9 +791,7 @@ DO-MOUSE-DRAG-REGION-POST-PROCESS should only be used by
(click-count (1- (event-click-count start-event)))
;; Suppress automatic hscrolling, because that is a nuisance
;; when setting point near the right fringe (but see below).
(auto-hscroll-mode-saved auto-hscroll-mode)
(auto-hscroll-mode nil)
moved-off-start event end end-point)
(auto-hscroll-mode-saved auto-hscroll-mode))
(setq mouse-selection-click-count click-count)
;; In case the down click is in the middle of some intangible text,
......@@ -798,23 +810,21 @@ DO-MOUSE-DRAG-REGION-POST-PROCESS should only be used by
(push-mark (nth 0 range) t t)
(goto-char (nth 1 range)))
;; Track the mouse until we get a non-movement event.
(track-mouse
(while (progn
(setq event (read-event))
(or (mouse-movement-p event)
(memq (car-safe event) '(switch-frame select-window))))
(unless (memq (car-safe event) '(switch-frame select-window))
;; Automatic hscrolling did not occur during the call to
;; `read-event'; but if the user subsequently drags the
;; mouse, go ahead and hscroll.
(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.
(setf (terminal-parameter nil 'mouse-drag-start) start-event)
(setq track-mouse t)
(setq auto-hscroll-mode nil)
(set-transient-map
(let ((map (make-sparse-keymap)))
(define-key map [switch-frame] #'ignore)
(define-key map [select-window] #'ignore)
(define-key map [mouse-movement]
(lambda (event) (interactive "e")
(let* ((end (event-end event))
(end-point (posn-point end)))
(unless (eq end-point start-point)
(setq moved-off-start t))
;; As soon as the user moves, we can re-enable auto-hscroll.
(setq auto-hscroll-mode auto-hscroll-mode-saved))
(if (and (eq (posn-window end) start-window)
(integer-or-marker-p end-point))
(mouse--drag-set-mark-and-point start-point
......@@ -828,55 +838,12 @@ DO-MOUSE-DRAG-REGION-POST-PROCESS should only be used by
((>= mouse-row bottom)
(mouse-scroll-subr start-window (1+ (- mouse-row bottom))
nil start-point))))))))
;; Handle the terminating event if possible.
(when (consp event)
;; Ensure that point is on the end of the last event.
(when (and (setq end-point (posn-point (event-end event)))
(eq (posn-window end) start-window)
(integer-or-marker-p end-point)
(/= start-point end-point))
(mouse--drag-set-mark-and-point start-point
end-point click-count))
;; Find its binding.
(let* ((fun (key-binding (vector (car event))))
;; FIXME This doesn't make sense, because
;; event-click-count always returns something >= 1.
(do-multi-click (and (> (event-click-count event) 0)
(functionp fun)
(not (memq fun '(mouse-set-point
mouse-set-region))))))
(if (and (/= (mark) (point))
(not do-multi-click))
;; If point has moved, finish the drag.
(let* (last-command this-command)
(and mouse-drag-copy-region
do-mouse-drag-region-post-process
(let (deactivate-mark)
(copy-region-as-kill (mark) (point)))))
;; Otherwise, run binding of terminating up-event.
map)
t (lambda ()
(setq track-mouse nil)
(setq auto-hscroll-mode auto-hscroll-mode-saved)
(deactivate-mark)
(if do-multi-click
(goto-char start-point)
(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
;; start changed in a redisplay after the
;; mouse-set-point for the down-mouse event at
;; the beginning of this function. When the
;; window start has changed, the up-mouse event
;; contains a different position due to the new
;; window contents, and point is set again.
(or end-point
(= (window-start start-window)
start-window-start)))
(push event unread-command-events)))))))
(pop-mark)))))
(defun mouse--drag-set-mark-and-point (start click click-count)
(let* ((range (mouse-start-end start click click-count))
......@@ -1904,14 +1871,10 @@ choose a font."
;;; Bindings for mouse commands.
(define-key global-map [down-mouse-1] 'mouse-drag-region)
(global-set-key [down-mouse-1] 'mouse-drag-region)
(global-set-key [mouse-1] 'mouse-set-point)
(global-set-key [drag-mouse-1] 'mouse-set-region)
;; These are tested for in mouse-drag-region.
(global-set-key [double-mouse-1] 'mouse-set-point)
(global-set-key [triple-mouse-1] 'mouse-set-point)
(defun mouse--strip-first-event (_prompt)
(substring (this-single-command-raw-keys) 1))
......
......@@ -83,7 +83,8 @@ Each element has the form (WINDOW . OVERLAY).")
(cond
((eq (car x) (selected-window)) (cdr x))
((not (and (window-live-p (car x))
(eq (window-buffer (car x)) (current-buffer))))
(eq (window-buffer (car x))
(current-buffer))))
;; Adopt this since it's owned by a window that's
;; either not live or at least not showing this
;; buffer any more.
......@@ -135,8 +136,9 @@ Each element has the form (WINDOW . OVERLAY).")
old-ols)
(defun reveal-close-old-overlays (old-ols)
(if (not (eq reveal-last-tick
(setq reveal-last-tick (buffer-modified-tick))))
(if (or track-mouse ;Don't close in the middle of a click.
(not (eq reveal-last-tick
(setq reveal-last-tick (buffer-modified-tick)))))
;; The buffer was modified since last command: let's refrain from
;; closing any overlay because it tends to behave poorly when
;; inserting text at the end of an overlay (basically the overlay
......
......@@ -42,13 +42,12 @@
(defvar xterm-mouse-debug-buffer nil)
(defvar xterm-mouse-last)
;; Mouse events symbols must have an 'event-kind property with
;; the value 'mouse-click.
(dolist (event-type '(mouse-1 mouse-2 mouse-3
M-down-mouse-1 M-down-mouse-2 M-down-mouse-3))
(put event-type 'event-kind 'mouse-click))
(dolist (event '(mouse-1 mouse-2 mouse-3 mouse-4 mouse-5))
(let ((M-event (intern (concat "M-" (symbol-name event)))))
(put event 'event-kind 'mouse-click)
(put M-event 'event-kind 'mouse-click)))
(defun xterm-mouse-translate (_event)
"Read a click and release event from XTerm."
......@@ -65,59 +64,47 @@ http://invisible-island.net/xterm/ctlseqs/ctlseqs.html)."
(save-excursion
(save-window-excursion ;FIXME: Why?
(deactivate-mark) ;FIXME: Why?
(let* ((xterm-mouse-last nil)
(down (xterm-mouse-event extension))
(down-command (nth 0 down))
(down-data (nth 1 down))
(down-where (nth 1 down-data))
(down-binding (key-binding (if (symbolp down-where)
(vector down-where down-command)
(vector down-command))))
(is-down (string-match "down" (symbol-name (car down)))))
;; Retrieve the expected preface for the up-event.
(unless is-down
(unless (cond ((null extension)
(and (eq (read-event) ?\e)
(eq (read-event) ?\[)
(eq (read-event) ?M)))
((eq extension 1006)
(and (eq (read-event) ?\e)
(eq (read-event) ?\[)
(eq (read-event) ?<))))
(error "Unexpected escape sequence from XTerm")))
;; Process the up-event.
(let* ((click (if is-down (xterm-mouse-event extension) down))
(click-data (nth 1 click))
(click-where (nth 1 click-data)))
(let* ((event (xterm-mouse-event extension))
(ev-command (nth 0 event))
(ev-data (nth 1 event))
(ev-where (nth 1 ev-data))
(vec (if (and (symbolp ev-where) (consp ev-where))
;; FIXME: This condition can *never* be non-nil!?!
(vector (list ev-where ev-data) event)
(vector event)))
(is-down (string-match "down-" (symbol-name ev-command))))
(cond
((null down) nil)
((memq down-binding '(nil ignore))
(if (and (symbolp click-where)
(consp click-where))
(vector (list click-where click-data) click)
(vector click)))
((null event) nil) ;Unknown/bogus byte sequence!
(is-down
(setf (terminal-parameter nil 'xterm-mouse-last-down) event)
vec)
(t
(let* ((down (terminal-parameter nil 'xterm-mouse-last-down))
(down-data (nth 1 down))
(down-where (nth 1 down-data)))
(setf (terminal-parameter nil 'xterm-mouse-last-down) nil)
(cond
((null down)
;; This is an "up-only" event. Pretend there was an up-event
;; right before and keep the up-event for later.
(push event unread-command-events)
(vector (cons (intern (replace-regexp-in-string
"\\`\\([ACMHSs]-\\)*" "\\&down-"
(symbol-name ev-command) t))
(cdr event))))
((equal ev-where down-where) vec)
(t
(setq unread-command-events
(append (if (eq down-where click-where)
(list click)
(list
;; Cheat `mouse-drag-region' with move event.
(list 'mouse-movement click-data)
;; Generate a drag event.
(if (symbolp down-where)
0
(list (intern (format "drag-mouse-%d"
(1+ xterm-mouse-last)))
down-data click-data))))
unread-command-events))
(if xterm-mouse-debug-buffer
(print unread-command-events xterm-mouse-debug-buffer))
(if (and (symbolp down-where)
(consp down-where))
(vector (list down-where down-data) down)
(vector down)))))))))
(let ((drag (if (symbolp ev-where)
0 ;FIXME: Why?!?
(list (replace-regexp-in-string
"\\`\\([ACMHSs]-\\)*" "\\&drag-"
(symbol-name ev-command) t)
down-data ev-data))))
(if (null track-mouse)
(vector drag)
(push drag unread-command-events)
(vector (list 'mouse-movement ev-data)))))))))))))
;; These two variables have been converted to terminal parameters.
;;
......@@ -165,16 +152,14 @@ http://invisible-island.net/xterm/ctlseqs/ctlseqs.html)."
(cond ((>= code 64)
(format "mouse-%d" (- code 60)))
((memq code '(8 9 10))
(setq xterm-mouse-last (- code 8))
(format "M-down-mouse-%d" (- code 7)))
((and (= code 11) xterm-mouse-last)
(format "M-mouse-%d" (1+ xterm-mouse-last)))
((and (= code 3) xterm-mouse-last)
;; For buttons > 5 xterm only reports a button-release event.
;; Drop them since they're not usable and can be spurious.
(format "mouse-%d" (1+ xterm-mouse-last)))
((memq code '(3 11))
(let ((down (car (terminal-parameter
nil 'xterm-mouse-last-down))))
(when (and down (string-match "[0-9]" (symbol-name down)))
(format (if (eq code 3) "mouse-%s" "M-mouse-%s")
(match-string 0 (symbol-name down))))))
((memq code '(0 1 2))
(setq xterm-mouse-last code)
(format "down-mouse-%d" (+ 1 code))))))
(x (- (read-event) 33))
(y (- (read-event) 33)))
......@@ -212,10 +197,20 @@ http://invisible-island.net/xterm/ctlseqs/ctlseqs.html)."
(if down "down-" "")
(if wheel
(- code 60)
(1+ (setq xterm-mouse-last (mod code 4)))))))
(1+ (mod code 4))))))
(1- (string-to-number (apply 'string (nreverse x-bytes))))
(1- (string-to-number (apply 'string (nreverse y-bytes)))))))
(defun xterm-mouse--set-click-count (event click-count)
(setcdr (cdr event) (list click-count))
(let ((name (symbol-name (car event))))
(when (string-match "\\(.*?\\)\\(\\(?:down-\\)?mouse-.*\\)" name)
(setcar event
(intern (concat (match-string 1 name)
(if (= click-count 2)
"double-" "triple-")
(match-string 2 name)))))))
(defun xterm-mouse-event (&optional extension)
"Convert XTerm mouse event to Emacs mouse event.
EXTENSION, if non-nil, means to use an extension to the usual
......@@ -241,18 +236,42 @@ which is the \"1006\" extension implemented in Xterm >= 277."
(w (window-at x y))
(ltrb (window-edges w))
(left (nth 0 ltrb))
(top (nth 1 ltrb)))
(set-terminal-parameter nil 'xterm-mouse-x x)
(set-terminal-parameter nil 'xterm-mouse-y y)
(setq
last-input-event
(list type
(let ((event (if w
(top (nth 1 ltrb))
(posn (if w
(posn-at-x-y (- x left) (- y top) w t)
(append (list nil 'menu-bar)
(nthcdr 2 (posn-at-x-y x y))))))
(setcar (nthcdr 3 event) timestamp)
event)))))))
(nthcdr 2 (posn-at-x-y x y)))))
(event (list type posn)))
(setcar (nthcdr 3 posn) timestamp)
;; Try to handle double/triple clicks.
(let* ((last-click (terminal-parameter nil 'xterm-mouse-last-click))
(last-type (nth 0 last-click))
(last-name (symbol-name last-type))
(last-time (nth 1 last-click))
(click-count (nth 2 last-click))
(this-time (float-time))
(name (symbol-name type)))
(cond
((not (string-match "down-" name))
;; For up events, make the up side match the down side.
(setq this-time last-time)
(when (and (> click-count 1)
(string-match "down-" last-name)
(equal name (replace-match "" t t last-name)))
(xterm-mouse--set-click-count event click-count)))
((not last-time) nil)
((and (> double-click-time (* 1000 (- this-time last-time)))
(equal last-name (replace-match "" t t name)))
(setq click-count (1+ click-count))
(xterm-mouse--set-click-count event click-count))
(t (setq click-count 1)))
(set-terminal-parameter nil 'xterm-mouse-last-click
(list type this-time click-count)))
(set-terminal-parameter nil 'xterm-mouse-x x)
(set-terminal-parameter nil 'xterm-mouse-y y)
(setq last-input-event event)))))
;;;###autoload
(define-minor-mode xterm-mouse-mode
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment