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