lisp/xt-mouse.el

   1 ;;; xt-mouse.el --- support the mouse when emacs run in an xterm
   2
   3 ;; Copyright (C) 1994, 2000-2014 Free Software Foundation, Inc.
   4
   5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
   6 ;; Keywords: mouse, terminals
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; Enable mouse support when running inside an xterm.
  26
  27 ;; This is actually useful when you are running X11 locally, but is
  28 ;; working on remote machine over a modem line or through a gateway.
  29
  30 ;; It works by translating xterm escape codes into generic emacs mouse
  31 ;; events so it should work with any package that uses the mouse.
  32
  33 ;; You don't have to turn off xterm mode to use the normal xterm mouse
  34 ;; functionality, it is still available by holding down the SHIFT key
  35 ;; when you press the mouse button.
  36
  37 ;;; Todo:
  38
  39 ;; Support multi-click -- somehow.
  40
  41 ;;; Code:
  42
  43 (defvar xterm-mouse-debug-buffer nil)
  44
  45 ;; Mouse events symbols must have an 'event-kind property with
  46 ;; the value 'mouse-click.
  47 (dolist (event '(mouse-1 mouse-2 mouse-3 mouse-4 mouse-5))
  48   (let ((M-event (intern (concat "M-" (symbol-name event)))))
  49     (put event 'event-kind 'mouse-click)
  50     (put M-event 'event-kind 'mouse-click)))
  51
  52 (defun xterm-mouse-translate (_event)
  53   "Read a click and release event from XTerm."
  54   (xterm-mouse-translate-1))
  55
  56 (defun xterm-mouse-translate-extended (_event)
  57   "Read a click and release event from XTerm.
  58 Similar to `xterm-mouse-translate', but using the \"1006\"
  59 extension, which supports coordinates >= 231 (see
  60 http://invisible-island.net/xterm/ctlseqs/ctlseqs.html)."
  61   (xterm-mouse-translate-1 1006))
  62
  63 (defun xterm-mouse-translate-1 (&optional extension)
  64   (save-excursion
  65     (save-window-excursion              ;FIXME: Why?
  66       (deactivate-mark)                 ;FIXME: Why?
  67       (let* ((event (xterm-mouse-event extension))
  68              (ev-command (nth 0 event))
  69              (ev-data    (nth 1 event))
  70              (ev-where   (nth 1 ev-data))
  71              (vec (if (and (symbolp ev-where) (consp ev-where))
  72                       ;; FIXME: This condition can *never* be non-nil!?!
  73                       (vector (list ev-where ev-data) event)
  74                     (vector event)))
  75              (is-down (string-match "down-" (symbol-name ev-command))))
  76
  77           (cond
  78          ((null event) nil)           ;Unknown/bogus byte sequence!
  79          (is-down
  80           (setf (terminal-parameter nil 'xterm-mouse-last-down) event)
  81           vec)
  82          (t
  83           (let* ((down (terminal-parameter nil 'xterm-mouse-last-down))
  84                  (down-data (nth 1 down))
  85                  (down-where (nth 1 down-data)))
  86             (setf (terminal-parameter nil 'xterm-mouse-last-down) nil)
  87             (cond
  88              ((null down)
  89               ;; This is an "up-only" event.  Pretend there was an up-event
  90               ;; right before and keep the up-event for later.
  91               (push event unread-command-events)
  92               (vector (cons (intern (replace-regexp-in-string
  93                                      "\\`\\([ACMHSs]-\\)*" "\\&down-"
  94                                      (symbol-name ev-command) t))
  95                             (cdr event))))
  96              ((equal ev-where down-where) vec)
  97            (t
  98               (let ((drag (if (symbolp ev-where)
  99                                  0      ;FIXME: Why?!?
 100                                (list (replace-regexp-in-string
 101                                       "\\`\\([ACMHSs]-\\)*" "\\&drag-"
 102                                       (symbol-name ev-command) t)
 103                                      down-data ev-data))))
 104                 (if (null track-mouse)
 105                     (vector drag)
 106                   (push drag unread-command-events)
 107                   (vector (list 'mouse-movement ev-data)))))))))))))
 108
 109 ;; These two variables have been converted to terminal parameters.
 110 ;;
 111 ;;(defvar xterm-mouse-x 0
 112 ;;  "Position of last xterm mouse event relative to the frame.")
 113 ;;
 114 ;;(defvar xterm-mouse-y 0
 115 ;;  "Position of last xterm mouse event relative to the frame.")
 116
 117 (defvar xt-mouse-epoch nil)
 118
 119 ;; Indicator for the xterm-mouse mode.
 120
 121 (defun xterm-mouse-position-function (pos)
 122   "Bound to `mouse-position-function' in XTerm mouse mode."
 123   (when (terminal-parameter nil 'xterm-mouse-x)
 124     (setcdr pos (cons (terminal-parameter nil 'xterm-mouse-x)
 125                       (terminal-parameter nil 'xterm-mouse-y))))
 126   pos)
 127
 128 (defun xterm-mouse-truncate-wrap (f)
 129   "Truncate with wrap-around."
 130   (condition-case nil
 131       ;; First try the built-in truncate, in case there's no overflow.
 132       (truncate f)
 133     ;; In case of overflow, do wraparound by hand.
 134     (range-error
 135      ;; In our case, we wrap around every 3 days or so, so if we assume
 136      ;; a maximum of 65536 wraparounds, we're safe for a couple years.
 137      ;; Using a power of 2 makes rounding errors less likely.
 138      (let* ((maxwrap (* 65536 2048))
 139             (dbig (truncate (/ f maxwrap)))
 140             (fdiff (- f (* 1.0 maxwrap dbig))))
 141        (+ (truncate fdiff) (* maxwrap dbig))))))
 142
 143 ;; Normal terminal mouse click reporting: expect three bytes, of the
 144 ;; form <BUTTON+32> <X+32> <Y+32>.  Return a list (EVENT-TYPE X Y).
 145 (defun xterm-mouse--read-event-sequence-1000 ()
 146   (let* ((code (- (read-event) 32))
 147          (type
 148           ;; For buttons > 3, the release-event looks differently
 149           ;; (see xc/programs/xterm/button.c, function EditorButton),
 150           ;; and come in a release-event only, no down-event.
 151           (cond ((>= code 64)
 152                  (format "mouse-%d" (- code 60)))
 153                 ((memq code '(8 9 10))
 154                  (format "M-down-mouse-%d" (- code 7)))
 155                 ((memq code '(3 11))
 156                  (let ((down (car (terminal-parameter
 157                                    nil 'xterm-mouse-last-down))))
 158                    (when (and down (string-match "[0-9]" (symbol-name down)))
 159                      (format (if (eq code 3) "mouse-%s" "M-mouse-%s")
 160                              (match-string 0 (symbol-name down))))))
 161                 ((memq code '(0 1 2))
 162                  (format "down-mouse-%d" (+ 1 code)))))
 163          (x (- (read-event) 33))
 164          (y (- (read-event) 33)))
 165     (and type (wholenump x) (wholenump y)
 166          (list (intern type) x y))))
 167
 168 ;; XTerm's 1006-mode terminal mouse click reporting has the form
 169 ;; <BUTTON> ; <X> ; <Y> <M or m>, where the button and ordinates are
 170 ;; in encoded (decimal) form.  Return a list (EVENT-TYPE X Y).
 171 (defun xterm-mouse--read-event-sequence-1006 ()
 172   (let (button-bytes x-bytes y-bytes c)
 173     (while (not (eq (setq c (read-event)) ?\;))
 174       (push c button-bytes))
 175     (while (not (eq (setq c (read-event)) ?\;))
 176       (push c x-bytes))
 177     (while (not (memq (setq c (read-event)) '(?m ?M)))
 178       (push c y-bytes))
 179     (list (let* ((code (string-to-number
 180                         (apply 'string (nreverse button-bytes))))
 181                  (wheel (>= code 64))
 182                  (down (and (not wheel)
 183                             (eq c ?M))))
 184             (intern (format "%s%smouse-%d"
 185                             (cond (wheel "")
 186                                   ((< code 4)  "")
 187                                   ((< code 8)  "S-")
 188                                   ((< code 12) "M-")
 189                                   ((< code 16) "M-S-")
 190                                   ((< code 20) "C-")
 191                                   ((< code 24) "C-S-")
 192                                   ((< code 28) "C-M-")
 193                                   ((< code 32) "C-M-S-")
 194                                   (t
 195                                    (error "Unexpected escape sequence from XTerm")))
 196                             (if down "down-" "")
 197                             (if wheel
 198                                 (- code 60)
 199                               (1+ (mod code 4))))))
 200           (1- (string-to-number (apply 'string (nreverse x-bytes))))
 201           (1- (string-to-number (apply 'string (nreverse y-bytes)))))))
 202
 203 (defun xterm-mouse--set-click-count (event click-count)
 204   (setcdr (cdr event) (list click-count))
 205   (let ((name (symbol-name (car event))))
 206     (when (string-match "\\(.*?\\)\\(\\(?:down-\\)?mouse-.*\\)" name)
 207       (setcar event
 208               (intern (concat (match-string 1 name)
 209                               (if (= click-count 2)
 210                                   "double-" "triple-")
 211                               (match-string 2 name)))))))
 212
 213 (defun xterm-mouse-event (&optional extension)
 214   "Convert XTerm mouse event to Emacs mouse event.
 215 EXTENSION, if non-nil, means to use an extension to the usual
 216 terminal mouse protocol; we currently support the value 1006,
 217 which is the \"1006\" extension implemented in Xterm >= 277."
 218   (let* ((click (cond ((null extension)
 219                        (xterm-mouse--read-event-sequence-1000))
 220                       ((eq extension 1006)
 221                        (xterm-mouse--read-event-sequence-1006))
 222                       (t
 223                        (error "Unsupported XTerm mouse protocol")))))
 224     (when click
 225       (let* ((type (nth 0 click))
 226              (x    (nth 1 click))
 227              (y    (nth 2 click))
 228              ;; Emulate timestamp information.  This is accurate enough
 229              ;; for default value of mouse-1-click-follows-link (450msec).
 230              (timestamp (xterm-mouse-truncate-wrap
 231                          (* 1000
 232                             (- (float-time)
 233                                (or xt-mouse-epoch
 234                                    (setq xt-mouse-epoch (float-time)))))))
 235              (w (window-at x y))
 236              (ltrb (window-edges w))
 237              (left (nth 0 ltrb))
 238              (top (nth 1 ltrb))
 239              (posn (if w
 240                                 (posn-at-x-y (- x left) (- y top) w t)
 241                               (append (list nil 'menu-bar)
 242                              (nthcdr 2 (posn-at-x-y x y)))))
 243              (event (list type posn)))
 244         (setcar (nthcdr 3 posn) timestamp)
 245
 246         ;; Try to handle double/triple clicks.
 247         (let* ((last-click (terminal-parameter nil 'xterm-mouse-last-click))
 248                (last-type (nth 0 last-click))
 249                (last-name (symbol-name last-type))
 250                (last-time (nth 1 last-click))
 251                (click-count (nth 2 last-click))
 252                (this-time (float-time))
 253                (name (symbol-name type)))
 254           (cond
 255            ((not (string-match "down-" name))
 256             ;; For up events, make the up side match the down side.
 257             (setq this-time last-time)
 258             (when (and (> click-count 1)
 259                        (string-match "down-" last-name)
 260                        (equal name (replace-match "" t t last-name)))
 261               (xterm-mouse--set-click-count event click-count)))
 262            ((not last-time) nil)
 263            ((and (> double-click-time (* 1000 (- this-time last-time)))
 264                  (equal last-name (replace-match "" t t name)))
 265             (setq click-count (1+ click-count))
 266             (xterm-mouse--set-click-count event click-count))
 267            (t (setq click-count 1)))
 268           (set-terminal-parameter nil 'xterm-mouse-last-click
 269                                   (list type this-time click-count)))
 270
 271         (set-terminal-parameter nil 'xterm-mouse-x x)
 272         (set-terminal-parameter nil 'xterm-mouse-y y)
 273         (setq last-input-event event)))))
 274
 275 ;;;###autoload
 276 (define-minor-mode xterm-mouse-mode
 277   "Toggle XTerm mouse mode.
 278 With a prefix argument ARG, enable XTerm mouse mode if ARG is
 279 positive, and disable it otherwise.  If called from Lisp, enable
 280 the mode if ARG is omitted or nil.
 281
 282 Turn it on to use Emacs mouse commands, and off to use xterm mouse commands.
 283 This works in terminal emulators compatible with xterm.  It only
 284 works for simple uses of the mouse.  Basically, only non-modified
 285 single clicks are supported.  When turned on, the normal xterm
 286 mouse functionality for such clicks is still available by holding
 287 down the SHIFT key while pressing the mouse button."
 288   :global t :group 'mouse
 289   (funcall (if xterm-mouse-mode 'add-hook 'remove-hook)
 290            'terminal-init-xterm-hook
 291            'turn-on-xterm-mouse-tracking-on-terminal)
 292   (if xterm-mouse-mode
 293       ;; Turn it on
 294       (progn
 295         (setq mouse-position-function #'xterm-mouse-position-function)
 296         (mapc #'turn-on-xterm-mouse-tracking-on-terminal (terminal-list)))
 297     ;; Turn it off
 298     (mapc #'turn-off-xterm-mouse-tracking-on-terminal (terminal-list))
 299     (setq mouse-position-function nil)))
 300
 301 (defconst xterm-mouse-tracking-enable-sequence
 302   "\e[?1000h\e[?1006h"
 303   "Control sequence to enable xterm mouse tracking.
 304 Enables basic tracking, then extended tracking on
 305 terminals that support it.")
 306
 307 (defconst xterm-mouse-tracking-disable-sequence
 308   "\e[?1006l\e[?1000l"
 309   "Reset the modes set by `xterm-mouse-tracking-enable-sequence'.")
 310
 311 (defun turn-on-xterm-mouse-tracking-on-terminal (&optional terminal)
 312   "Enable xterm mouse tracking on TERMINAL."
 313   (when (and xterm-mouse-mode (eq t (terminal-live-p terminal))
 314              ;; Avoid the initial terminal which is not a termcap device.
 315              ;; FIXME: is there more elegant way to detect the initial terminal?
 316              (not (string= (terminal-name terminal) "initial_terminal")))
 317     (unless (terminal-parameter terminal 'xterm-mouse-mode)
 318       ;; Simulate selecting a terminal by selecting one of its frames
 319       ;; so that we can set the terminal-local `input-decode-map'.
 320       (with-selected-frame (car (frames-on-display-list terminal))
 321         (define-key input-decode-map "\e[M" 'xterm-mouse-translate)
 322         (define-key input-decode-map "\e[<" 'xterm-mouse-translate-extended))
 323       (send-string-to-terminal xterm-mouse-tracking-enable-sequence terminal)
 324       (push xterm-mouse-tracking-enable-sequence
 325             (terminal-parameter nil 'tty-mode-set-strings))
 326       (push xterm-mouse-tracking-disable-sequence
 327             (terminal-parameter nil 'tty-mode-reset-strings))
 328       (set-terminal-parameter terminal 'xterm-mouse-mode t))))
 329
 330 (defun turn-off-xterm-mouse-tracking-on-terminal (terminal)
 331   "Disable xterm mouse tracking on TERMINAL."
 332   ;; Only send the disable command to those terminals to which we've already
 333   ;; sent the enable command.
 334   (when (and (terminal-parameter terminal 'xterm-mouse-mode)
 335              (eq t (terminal-live-p terminal)))
 336     ;; We could remove the key-binding and unset the `xterm-mouse-mode'
 337     ;; terminal parameter, but it seems less harmful to send this escape
 338     ;; command too many times (or to catch an unintended key sequence), than
 339     ;; to send it too few times (or to fail to let xterm-mouse events
 340     ;; pass by untranslated).
 341     (send-string-to-terminal xterm-mouse-tracking-disable-sequence terminal)
 342     (setf (terminal-parameter nil 'tty-mode-set-strings)
 343           (remq xterm-mouse-tracking-enable-sequence
 344                 (terminal-parameter nil 'tty-mode-set-strings)))
 345     (setf (terminal-parameter nil 'tty-mode-reset-strings)
 346           (remq xterm-mouse-tracking-disable-sequence
 347                 (terminal-parameter nil 'tty-mode-reset-strings)))
 348     (set-terminal-parameter terminal 'xterm-mouse-mode nil)))
 349
 350 (provide 'xt-mouse)
 351
 352 ;;; xt-mouse.el ends here