lisp/xt-mouse.el

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