4 files changed, 168 insertions, 168 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 72c6d943710..52c1f0c164a 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,5 +1,21 @@
 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.
diff --git a/lisp/mouse.el b/lisp/mouse.el
index 9b1422f0658..ca94a343c1a 100644
--- a/lisp/mouse.el
+++ b/lisp/mouse.el
@@ -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))
 
diff --git a/lisp/reveal.el b/lisp/reveal.el
index f251c05f5eb..8d611ea04df 100644
--- a/lisp/reveal.el
+++ b/lisp/reveal.el
@@ -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
diff --git a/lisp/xt-mouse.el b/lisp/xt-mouse.el
index fc515974036..54fd1a44d5b 100644
--- a/lisp/xt-mouse.el
+++ b/lisp/xt-mouse.el
@@ -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