This version does *not* work with Emacs 22.

It is just the initial import from gpm-1.20.1.

1 files changed, 342 insertions, 0 deletions

diff --git a/lisp/t-mouse.el b/lisp/t-mouse.el
new file mode 100644
index 00000000000..88f6ef1b12c
--- /dev/null
+++ b/lisp/t-mouse.el
@@ -0,0 +1,342 @@
+;;; t-mouse.el --- mouse support within the text terminal
+
+;;; Copyright (C) 1994,1995 Alessandro Rubini <rubini@linux.it>
+;;;               parts are by Ian T Zimmermann <itz@rahul.net>, 1995,1998
+
+;; Maintainer: gpm mailing list: gpm@prosa.it
+;; Keywords: mouse gpm linux
+
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Emacs; see the file COPYING.  If not, write to
+;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; This package provides access to mouse event as reported by the
+;; gpm-Linux package. It uses the program "mev" to get mouse events.
+;; It tries to reproduce the functionality offered by emacs under X.
+;; The "gpm" server runs under Linux, so this package is rather
+;; Linux-dependent.
+
+;; Developed for GNU Emacs 19.34, likely won't work with many others
+;; too much internals dependent cruft here.
+
+
+(require 'advice)
+
+(defvar t-mouse-process nil 
+  "Embeds the process which passes mouse events to emacs.
+It is used by the program t-mouse.")
+
+(defvar t-mouse-filter-accumulator ""
+  "Accumulates input from the mouse reporting process.")
+
+(defvar t-mouse-debug-buffer nil
+  "Events normally posted to command queue are printed here in debug mode.
+See `t-mouse-start-debug'.")
+
+(defvar t-mouse-current-xy '(0 . 0)
+  "Stores the last mouse position t-mouse has been told about.")
+
+(defvar t-mouse-drag-start nil
+  "Whenever a drag starts in a special part of a window
+(not the text), the `translated' starting coordinates including the
+window and part involved are saved here.  This is necessary lest they
+get re-translated when the button goes up, at which time window
+configuration may have changed.")
+
+(defvar t-mouse-prev-set-selection-function 'x-set-selection)
+(defvar t-mouse-prev-get-selection-function 'x-get-selection)
+
+(defvar t-mouse-swap-alt-keys nil
+  "When set, Emacs will handle mouse events with the right Alt
+(a.k.a. Alt-Ger) modifier, not with the regular left Alt modifier.
+Useful for people who play strange games with their keyboard tables.")
+
+(defvar t-mouse-fix-21 nil 
+  "Enable brain-dead chords for 2 button mice.")
+
+
+;;; Code:
+
+;; get the number of the current virtual console
+
+(defun t-mouse-tty ()
+  "Returns number of virtual terminal Emacs is running on, as a string.
+For example, \"2\" for /dev/tty2."
+  (let ((buffer (generate-new-buffer "*t-mouse*")))
+    (call-process "ps" nil buffer nil "h" (format "%s" (emacs-pid)))
+    (prog1 (save-excursion
+             (set-buffer buffer)
+             (goto-char (point-min))
+             (if (or
+		  ;; Many versions of "ps", all different....
+		  (re-search-forward " +tty\\(.?[0-9a-f]\\)" nil t)
+		  (re-search-forward "p \\([0-9a-f]\\)" nil t)
+		  (re-search-forward "v0\\([0-9a-f]\\)" nil t)
+		  (re-search-forward "[0-9]+ +\\([0-9]+\\)" nil t)
+		  (re-search-forward "[\\t ]*[0-9]+[\\t ]+\\([0-9]+\\)" nil t))
+                 (buffer-substring (match-beginning 1) (match-end 1))))
+      (kill-buffer buffer))))
+
+
+;; due to a horrible kludge in Emacs' keymap handler
+;; (read_key_sequence) mouse clicks on funny parts of windows generate
+;; TWO events, the first being a dummy of the sort '(mode-line).
+;; That's why Per Abrahamsen's code in xt-mouse.el doesn't work for
+;; the modeline, for instance.
+
+;; now get this:  the Emacs C code that generates these fake events
+;; depends on certain things done by the very lowest level input
+;; handlers; namely the symbols for the events (for instance
+;; 'C-S-double-mouse-2) must have an 'event-kind property, set to
+;; 'mouse-click.  Since events from unread-command-events do not pass
+;; through the low level handlers, they don't get this property unless
+;; I set it myself.  I imagine this has caused innumerable attempts by
+;; hackers to do things similar to t-mouse to lose.
+
+;; The next page of code is devoted to fixing this ugly problem.
+
+;; WOW! a fully general powerset generator
+;; (C) Ian Zimmerman Mon Mar 23 12:00:16 PST 1998 :-)
+(defun t-mouse-powerset (l)
+  (if (null l) '(nil)
+    (let ((l1 (t-mouse-powerset (cdr l)))
+          (first (nth 0 l)))
+      (append
+       (mapcar (function (lambda (l) (cons first l))) l1) l1))))
+
+;; and a slightly less general cartesian product
+(defun t-mouse-cartesian (l1 l2)
+  (if (null l1) l2
+    (append (mapcar (function (lambda (x) (append (nth 0 l1) x))) l2)
+            (t-mouse-cartesian (cdr l1) l2))))
+      
+(let* ((modifier-sets (t-mouse-powerset '(control meta shift)))
+       (typed-sets (t-mouse-cartesian '((down) (drag))
+                                      '((mouse-1) (mouse-2) (mouse-3))))
+       (multipled-sets (t-mouse-cartesian '((double) (triple)) typed-sets))
+       (all-sets (t-mouse-cartesian modifier-sets multipled-sets)))
+  (while all-sets
+    (let ((event-sym (event-convert-list (nth 0 all-sets))))
+      (if (not (get event-sym 'event-kind))
+          (put event-sym 'event-kind 'mouse-click)))
+    (setq all-sets (cdr all-sets))))
+
+
+;;; This fun is partly Copyright (C) 1994 Per Abrahamsen <abraham@iesd.auc.dk>
+;; This is basically a feeble attempt to mimic what the c function
+;; buffer_posn_from_coords in dispnew.c does.  I wish that function
+;; were exported to Lisp.
+
+(defun t-mouse-lispy-buffer-posn-from-coords (w col line)
+  "Return buffer position of character at COL and LINE within window W.
+COL and LINE are glyph coordinates, relative to W topleft corner."
+  (save-window-excursion
+    (select-window w)
+    (save-excursion
+      (move-to-window-line line)
+      (move-to-column (+ col (current-column)
+                         (if (not (window-minibuffer-p w)) 0
+                           (- (minibuffer-prompt-width)))
+                         (max 0 (1- (window-hscroll)))))
+      (point))))
+
+;; compute one element of the form (WINDOW BUFFERPOS (COL . ROW) TIMESTAMP)
+
+(defun t-mouse-make-event-element (x-dot-y-avec-time)
+  (let* ((x-dot-y (nth 0 x-dot-y-avec-time))
+         (x (car x-dot-y))
+         (y (cdr x-dot-y))
+         (timestamp (nth 1 x-dot-y-avec-time))
+         (w (window-at x y))
+         (left-top-right-bottom (window-edges w))
+         (left (nth 0 left-top-right-bottom))
+         (top (nth 1 left-top-right-bottom))
+         (right (nth 2 left-top-right-bottom))
+         (bottom (nth 3 left-top-right-bottom))
+         (coords-or-part (coordinates-in-window-p x-dot-y w)))
+    (cond
+     ((consp coords-or-part)
+      (let ((wx (car coords-or-part)) (wy (cdr coords-or-part)))
+        (if (< wx (- right left 1))
+            (list w 
+                  (t-mouse-lispy-buffer-posn-from-coords w wx wy)
+                  coords-or-part timestamp)
+          (list w 'vertical-scroll-bar
+                (cons (1+ wy) (- bottom top)) timestamp))))
+     ((eq coords-or-part 'mode-line)
+      (list w 'mode-line (cons (- x left) 0) timestamp))
+     ((eq coords-or-part 'vertical-line)
+      (list w 'vertical-line (cons 0 (- y top)) timestamp)))))     
+
+;;; This fun is partly Copyright (C) 1994 Per Abrahamsen <abraham@iesd.auc.dk>
+
+(defun t-mouse-make-event ()
+  "Makes a Lisp style event from the contents of mouse input accumulator.
+Also trims the accumulator by all the data used to build the event."
+  (let (ob (ob-pos (condition-case nil
+                       (read-from-string t-mouse-filter-accumulator)
+                     (error nil))))
+    (if (not ob-pos) nil
+      (setq ob (car ob-pos))
+      (setq t-mouse-filter-accumulator
+            (substring t-mouse-filter-accumulator (cdr ob-pos)))
+
+      ;;now the real work
+
+      (let ((event-type (nth 0 ob))
+            (current-xy-avec-time (nth 1 ob))
+            (type-switch (length ob)))
+
+ 	(if t-mouse-fix-21
+            (let
+                ;;Acquire the event's symbol's name.
+                ((event-name-string (symbol-name event-type))
+                 end-of-root-event-name
+                 new-event-name-string)
+ 
+              (if (string-match "-\\(21\\|\\12\\)$" event-name-string)
+ 
+                  ;;Transform the name to what it should have been.
+                  (progn
+                    (setq end-of-root-event-name (match-beginning 0))
+                    (setq new-event-name-string
+                          (concat (substring  
+                                   event-name-string 0
+                                   end-of-root-event-name) "-3"))
+ 	      
+                    ;;Change the event to the symbol that corresponds to the
+                    ;;name we made. The proper symbol already exists.
+                    (setq event-type 
+                          (intern new-event-name-string))))))
+ 	
+        ;;store current position for mouse-position
+
+        (setq t-mouse-current-xy (nth 0 current-xy-avec-time))
+
+        ;;events have many types but fortunately they differ in length
+
+        (cond
+         ;;sink all events on the stupid text mode menubar.
+         ((and menu-bar-mode (eq 0 (cdr t-mouse-current-xy))) nil)
+         ((= type-switch 4)             ;must be drag
+          (let ((count (nth 2 ob))
+                (start-element
+                 (or t-mouse-drag-start
+                     (t-mouse-make-event-element (nth 3 ob))))
+                (end-element
+                 (t-mouse-make-event-element current-xy-avec-time)))
+            (setq t-mouse-drag-start nil)
+            (list event-type start-element end-element count)))
+         ((= type-switch 3)             ;down or up
+          (let ((count (nth 2 ob))
+                (element
+                 (t-mouse-make-event-element current-xy-avec-time)))
+            (if (and (not t-mouse-drag-start)
+                     (symbolp (nth 1 element)))
+                ;; OUCH! GOTCHA! emacs uses setc[ad]r on these!
+                (setq t-mouse-drag-start (copy-sequence element))
+              (setq t-mouse-drag-start nil))
+            (list event-type element count)))
+         ((= type-switch 2)             ;movement
+          (list (if (eq 'vertical-scroll-bar
+                        (nth 1 t-mouse-drag-start)) 'scroll-bar-movement
+                  'mouse-movement)
+                (t-mouse-make-event-element current-xy-avec-time))))))))
+
+
+(defun t-mouse-process-filter (proc string)
+  (setq t-mouse-filter-accumulator
+        (concat t-mouse-filter-accumulator string))
+  (let ((event (t-mouse-make-event)))
+    (while event
+      (if (or track-mouse 
+              (not (eq 'mouse-movement (event-basic-type event))))
+          (setq unread-command-events
+                (nconc unread-command-events (list event))))
+      (if t-mouse-debug-buffer
+          (print unread-command-events t-mouse-debug-buffer))
+      (setq event (t-mouse-make-event)))))
+
+
+;; this overrides a C function which stupidly assumes (no X => no mouse)
+(defadvice mouse-position (around t-mouse-mouse-position activate)
+  "Return the t-mouse-position unless running with a window system.
+The (secret) scrollbar interface is not implemented yet."
+  (if (not window-system)
+      (setq ad-return-value
+            (cons (selected-frame) t-mouse-current-xy))
+    ad-do-it))
+
+(setq mouse-sel-set-selection-function
+      (function (lambda (type value)
+                  (if (not window-system)
+                      (if (eq 'PRIMARY type) (kill-new value))
+                    (funcall t-mouse-prev-set-selection-function
+                             type value)))))
+
+(setq mouse-sel-get-selection-function
+      (function (lambda (type)
+                  (if (not window-system)
+                      (if (eq 'PRIMARY type)
+                          (current-kill 0) "")
+                    (funcall t-mouse-prev-get-selection-function type)))))
+
+;; It should be possible to just send SIGTSTP to the inferior with
+;; stop-process.  That doesn't work; mev receives the signal fine but
+;; is not really stopped: instead it returns from
+;; kill(getpid(), SIGTSTP) immediately.  I don't understand what's up
+;; itz Tue Mar 24 14:27:38 PST 1998. 
+
+(add-hook 'suspend-hook
+          (function (lambda ()
+                      (and t-mouse-process
+                           ;(stop-process t-mouse-process)
+                           (process-send-string
+                            t-mouse-process "push -enone -dall -Mnone\n")))))
+
+(add-hook 'suspend-resume-hook
+          (function (lambda ()
+                      (and t-mouse-process
+                           ;(continue-process t-mouse-process)
+                           (process-send-string t-mouse-process "pop\n")))))
+
+
+;;; User commands
+
+(defun t-mouse-stop ()
+  "Stop getting mouse events from an asynchronous process."
+  (interactive)
+  (delete-process t-mouse-process)
+  (setq t-mouse-process nil))
+
+(defun t-mouse-run ()
+  "Starts getting a stream of mouse events from an asynchronous process.
+Only works if Emacs is running on a virtual terminal without a window system.
+Returns the newly created asynchronous process."
+  (interactive)
+  (let ((tty (t-mouse-tty))
+        (process-connection-type t))
+    (if (or window-system (not (stringp tty)))
+        (error "Run t-mouse on a virtual terminal without a window system"))
+    (setq t-mouse-process 
+          (start-process "t-mouse" nil
+                         "mev" "-i" "-E" "-C" tty
+                         (if t-mouse-swap-alt-keys
+                             "-M-leftAlt" "-M-rightAlt")
+                         "-e-move" "-dall" "-d-hard"
+                         "-f")))
+  (setq t-mouse-filter-accumulator "")
+  (set-process-filter t-mouse-process 't-mouse-process-filter)
+  (process-kill-without-query t-mouse-process)
+  t-mouse-process)
+
+(provide 't-mouse)
+
+;;; t-mouse.el ends here