lisp/t-mouse.el

   1 ;;; t-mouse.el --- mouse support within the text terminal
   2
   3 ;; Authors: Alessandro Rubini and Ian T Zimmerman
   4 ;; Maintainer: Nick Roberts <nickrob@gnu.org>
   5 ;; Keywords: mouse gpm linux
   6
   7 ;; Copyright (C) 1994, 1995, 1998, 2006, 2007, 2008 Free Software Foundation, Inc.
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 3, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; This package provides access to mouse event as reported by the
  29 ;; gpm-Linux package.  It uses the program "mev" to get mouse events.
  30 ;; It tries to reproduce the functionality offered by Emacs under X.
  31 ;; The "gpm" server runs under Linux, so this package is rather
  32 ;; Linux-dependent.
  33
  34 ;; Modified by Nick Roberts for Emacs 22.  In particular, the mode-line is
  35 ;; now position sensitive.
  36
  37 (defvar t-mouse-process nil
  38   "Embeds the process which passes mouse events to Emacs.
  39 It is used by the program t-mouse.")
  40
  41 (defvar t-mouse-filter-accumulator ""
  42   "Accumulates input from the mouse reporting process.")
  43
  44 (defvar t-mouse-debug-buffer nil
  45   "Events normally posted to command queue are printed here in debug mode.
  46 See `t-mouse-start-debug'.")
  47
  48 (defvar t-mouse-current-xy '(0 . 0)
  49   "Stores the last mouse position t-mouse has been told about.")
  50
  51 (defvar t-mouse-drag-start nil
  52   "Whenever a drag starts in a special part of a window
  53 \(not the text), the `translated' starting coordinates including the
  54 window and part involved are saved here.  This is necessary lest they
  55 get re-translated when the button goes up, at which time window
  56 configuration may have changed.")
  57
  58 (defvar t-mouse-prev-set-selection-function 'x-set-selection)
  59 (defvar t-mouse-prev-get-selection-function 'x-get-selection)
  60
  61 (defvar t-mouse-swap-alt-keys nil
  62   "When set, Emacs will handle mouse events with the right Alt
  63 \(a.k.a.  Alt-Ger) modifier, not with the regular left Alt modifier.
  64 Useful for people who play strange games with their keyboard tables.")
  65
  66 (defvar t-mouse-fix-21 nil
  67   "Enable brain-dead chords for 2 button mice.")
  68
  69 \f
  70 ;;; Code:
  71
  72 ;; get the number of the current virtual console
  73
  74 (defun t-mouse-tty ()
  75   "Return number of virtual terminal Emacs is running on, as a string.
  76 For example, \"2\" for /dev/tty2."
  77   (with-temp-buffer
  78     (call-process "ps" nil t nil "h" (format "%s" (emacs-pid)))
  79     (goto-char (point-min))
  80     (if (or
  81          ;; Many versions of "ps", all different....
  82          (re-search-forward " +tty\\(.?[0-9a-f]\\)" nil t)
  83          (re-search-forward "p \\([0-9a-f]\\)" nil t)
  84          (re-search-forward "v0\\([0-9a-f]\\)" nil t)
  85          (re-search-forward "[0-9]+ +\\([0-9]+\\)" nil t)
  86          (re-search-forward "[\\t ]*[0-9]+[\\t ]+\\([0-9]+\\)" nil t)
  87          (re-search-forward " +vc/\\(.?[0-9a-f]\\)" nil t)
  88          (re-search-forward " +pts/\\(.?[0-9a-f]\\)" nil t))
  89         (buffer-substring (match-beginning 1) (match-end 1)))))
  90
  91 \f
  92 ;; due to a horrible kludge in Emacs' keymap handler
  93 ;; (read_key_sequence) mouse clicks on funny parts of windows generate
  94 ;; TWO events, the first being a dummy of the sort '(mode-line).
  95 ;; That's why Per Abrahamsen's code in xt-mouse.el doesn't work for
  96 ;; the modeline, for instance.
  97
  98 ;; now get this:  the Emacs C code that generates these fake events
  99 ;; depends on certain things done by the very lowest level input
 100 ;; handlers; namely the symbols for the events (for instance
 101 ;; 'C-S-double-mouse-2) must have an 'event-kind property, set to
 102 ;; 'mouse-click.  Since events from unread-command-events do not pass
 103 ;; through the low level handlers, they don't get this property unless
 104 ;; I set it myself.  I imagine this has caused innumerable attempts by
 105 ;; hackers to do things similar to t-mouse to lose.
 106
 107 ;; The next page of code is devoted to fixing this ugly problem.
 108
 109 ;; WOW! a fully general powerset generator
 110 ;; (C) Ian Zimmerman Mon Mar 23 12:00:16 PST 1998 :-)
 111 (defun t-mouse-powerset (l)
 112   (if (null l) '(nil)
 113     (let ((l1 (t-mouse-powerset (cdr l)))
 114           (first (nth 0 l)))
 115       (append
 116        (mapcar (function (lambda (l) (cons first l))) l1) l1))))
 117
 118 ;; and a slightly less general cartesian product
 119 (defun t-mouse-cartesian (l1 l2)
 120   (if (null l1) l2
 121     (append (mapcar (function (lambda (x) (append (nth 0 l1) x))) l2)
 122             (t-mouse-cartesian (cdr l1) l2))))
 123
 124 (let* ((modifier-sets (t-mouse-powerset '(control meta shift)))
 125        (typed-sets (t-mouse-cartesian '((down) (drag))
 126                                       '((mouse-1) (mouse-2) (mouse-3))))
 127        (multipled-sets (t-mouse-cartesian '((double) (triple)) typed-sets))
 128        (all-sets (t-mouse-cartesian modifier-sets multipled-sets)))
 129   (while all-sets
 130     (let ((event-sym (event-convert-list (nth 0 all-sets))))
 131       (if (not (get event-sym 'event-kind))
 132           (put event-sym 'event-kind 'mouse-click)))
 133     (setq all-sets (cdr all-sets))))
 134
 135 (defun t-mouse-make-event-element (x-dot-y-avec-time)
 136   (let* ((x-dot-y (nth 0 x-dot-y-avec-time))
 137          (time (nth 1 x-dot-y-avec-time))
 138          (x (car x-dot-y))
 139          (y (cdr x-dot-y))
 140          (w (window-at x y))
 141          (ltrb (window-edges w))
 142          (left (nth 0 ltrb))
 143          (top (nth 1 ltrb))
 144          (event (if w
 145                     (posn-at-x-y (- x left) (- y top) w t)
 146                   (append (list nil 'menu-bar)
 147                           (nthcdr 2 (posn-at-x-y x y))))))
 148     (setcar (nthcdr 3 event) time)
 149     event))
 150
 151 ;;; This fun is partly Copyright (C) 1994 Per Abrahamsen <abraham@iesd.auc.dk>
 152 (defun t-mouse-make-event ()
 153   "Make a Lisp style event from the contents of mouse input accumulator.
 154 Also trim the accumulator by all the data used to build the event."
 155   (let (ob (ob-pos (condition-case nil
 156                        (progn
 157                          ;; this test is just needed for Fedora Core 3
 158                          (if (string-match "STILL RUNNING_1\n"
 159                                            t-mouse-filter-accumulator)
 160                              (setq t-mouse-filter-accumulator
 161                                    (substring
 162                                     t-mouse-filter-accumulator (match-end 0))))
 163                          (read-from-string t-mouse-filter-accumulator))
 164                      (error nil))))
 165     ;; this test is just needed for Fedora Core 3
 166     (if (or (eq (car ob-pos) 'STILL) (eq (car ob-pos) '***) (not ob-pos))
 167         nil
 168       (setq ob (car ob-pos))
 169       (if (string-match "mev:$" (prin1-to-string ob))
 170           (error "Can't open mouse connection"))
 171       (setq t-mouse-filter-accumulator
 172             (substring t-mouse-filter-accumulator (cdr ob-pos)))
 173
 174       ;;now the real work
 175
 176       (let ((event-type (nth 0 ob))
 177             (current-xy-avec-time (nth 1 ob))
 178             (type-switch (length ob)))
 179         (if t-mouse-fix-21
 180             (let
 181                 ;;Acquire the event's symbol's name.
 182                 ((event-name-string (symbol-name event-type))
 183                  end-of-root-event-name
 184                  new-event-name-string)
 185
 186               (if (string-match "-\\(21\\|\\12\\)$" event-name-string)
 187
 188                   ;;Transform the name to what it should have been.
 189                   (progn
 190                     (setq end-of-root-event-name (match-beginning 0))
 191                     (setq new-event-name-string
 192                           (concat (substring
 193                                    event-name-string 0
 194                                    end-of-root-event-name) "-3"))
 195
 196                     ;;Change the event to the symbol that corresponds to the
 197                     ;;name we made. The proper symbol already exists.
 198                     (setq event-type
 199                           (intern new-event-name-string))))))
 200
 201         ;;store current position for mouse-position
 202
 203         (setq t-mouse-current-xy (nth 0 current-xy-avec-time))
 204
 205         ;;events have many types but fortunately they differ in length
 206
 207         (cond
 208          ((= type-switch 4)             ;must be drag
 209           (let ((count (nth 2 ob))
 210                 (start-element
 211                  (or t-mouse-drag-start
 212                      (t-mouse-make-event-element (nth 3 ob))))
 213                 (end-element
 214                  (t-mouse-make-event-element current-xy-avec-time)))
 215             (setq t-mouse-drag-start nil)
 216             (list event-type start-element end-element count)))
 217          ((= type-switch 3)             ;down or up
 218           (let ((count (nth 2 ob))
 219                 (element
 220                  (t-mouse-make-event-element current-xy-avec-time)))
 221             (if (and (not t-mouse-drag-start)
 222                      (symbolp (nth 1 element)))
 223                 ;; OUCH! GOTCHA! emacs uses setc[ad]r on these!
 224                 (setq t-mouse-drag-start (copy-sequence element))
 225               (setq t-mouse-drag-start nil))
 226             (list event-type element count)))
 227          ((= type-switch 2)             ;movement
 228           (list (if (eq 'vertical-scroll-bar
 229                         (nth 1 t-mouse-drag-start)) 'scroll-bar-movement
 230                   'mouse-movement)
 231                 (t-mouse-make-event-element current-xy-avec-time))))))))
 232
 233 (defun t-mouse-process-filter (proc string)
 234   (setq t-mouse-filter-accumulator
 235         (concat t-mouse-filter-accumulator string))
 236   (let ((event (t-mouse-make-event)))
 237     (while event
 238       (if (or track-mouse
 239               (not (eq 'mouse-movement (event-basic-type event))))
 240           (setq unread-command-events
 241                 (nconc unread-command-events (list event))))
 242       (if t-mouse-debug-buffer
 243           (print unread-command-events t-mouse-debug-buffer))
 244       (setq event (t-mouse-make-event)))))
 245
 246 (defun t-mouse-mouse-position-function (pos)
 247   "Return the t-mouse-position unless running with a window system.
 248 The (secret) scrollbar interface is not implemented yet."
 249   (setcdr pos t-mouse-current-xy)
 250   pos)
 251
 252 ;; It should be possible to just send SIGTSTP to the inferior with
 253 ;; stop-process.  That doesn't work; mev receives the signal fine but
 254 ;; is not really stopped: instead it returns from
 255 ;; kill(getpid(), SIGTSTP) immediately.  I don't understand what's up
 256 ;; itz Tue Mar 24 14:27:38 PST 1998.
 257
 258 (add-hook 'suspend-hook
 259           (function (lambda ()
 260                       (and t-mouse-process
 261                            ;(stop-process t-mouse-process)
 262                            (process-send-string
 263                             t-mouse-process "push -enone -dall -Mnone\n")))))
 264
 265 (add-hook 'suspend-resume-hook
 266           (function (lambda ()
 267                       (and t-mouse-process
 268                            ;(continue-process t-mouse-process)
 269                            (process-send-string t-mouse-process "pop\n")))))
 270
 271 ;;;###autoload
 272 (define-minor-mode t-mouse-mode
 273   "Toggle t-mouse mode to use the mouse in Linux consoles.
 274 With prefix arg, turn t-mouse mode on if arg is positive, otherwise turn it
 275 off.
 276
 277 This allows the use of the mouse when operating on a Linux console, in the
 278 same way as you can use the mouse under X11.
 279 It requires the `mev' program, part of the `gpm' utilities."
 280   nil " Mouse" nil :global t
 281   (if t-mouse-mode
 282       ;; Turn it on
 283       (unless window-system
 284         ;; Starts getting a stream of mouse events from an asynchronous process.
 285         ;; Only works if Emacs is running on a virtual terminal without a window system.
 286         (progn
 287          (setq mouse-position-function #'t-mouse-mouse-position-function)
 288          (let ((tty (t-mouse-tty))
 289                (process-connection-type t))
 290            (if (not (stringp tty))
 291                (error "Cannot find a virtual terminal"))
 292            (setq t-mouse-process
 293                  (start-process "t-mouse" nil
 294                                 "mev" "-i" "-E" "-C" tty
 295                                 (if t-mouse-swap-alt-keys
 296                                     "-M-leftAlt" "-M-rightAlt")
 297                                 "-e-move"
 298                                 "-dall" "-d-hard"
 299                                 "-f")))
 300          (setq t-mouse-filter-accumulator "")
 301          (set-process-filter t-mouse-process 't-mouse-process-filter)
 302          (set-process-query-on-exit-flag t-mouse-process nil)))
 303     ;; Turn it off
 304     (setq mouse-position-function nil)
 305     (delete-process t-mouse-process)
 306     (setq t-mouse-process nil)))
 307
 308 (provide 't-mouse)
 309
 310 ;; arch-tag: a63163b3-bfbe-4eb2-ab4f-201cd164b05d
 311 ;;; t-mouse.el ends here