Commit | Line | Data |
---|---|---|
9efe4a2d NR |
1 | ;;; t-mouse.el --- mouse support within the text terminal |
2 | ||
3 | ;;; Copyright (C) 1994,1995 Alessandro Rubini <rubini@linux.it> | |
4 | ;;; parts are by Ian T Zimmermann <itz@rahul.net>, 1995,1998 | |
5 | ||
6 | ;; Maintainer: gpm mailing list: gpm@prosa.it | |
7 | ;; Keywords: mouse gpm linux | |
8 | ||
9 | ;;; This program is distributed in the hope that it will be useful, | |
10 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
12 | ;;; GNU General Public License for more details. | |
13 | ||
14 | ;;; You should have received a copy of the GNU General Public License | |
15 | ;;; along with GNU Emacs; see the file COPYING. If not, write to | |
16 | ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
17 | ||
18 | ;;; Commentary: | |
19 | ||
20 | ;; This package provides access to mouse event as reported by the | |
21 | ;; gpm-Linux package. It uses the program "mev" to get mouse events. | |
22 | ;; It tries to reproduce the functionality offered by emacs under X. | |
23 | ;; The "gpm" server runs under Linux, so this package is rather | |
24 | ;; Linux-dependent. | |
25 | ||
26 | ;; Developed for GNU Emacs 19.34, likely won't work with many others | |
27 | ;; too much internals dependent cruft here. | |
28 | ||
29 | \f | |
30 | (require 'advice) | |
31 | ||
32 | (defvar t-mouse-process nil | |
33 | "Embeds the process which passes mouse events to emacs. | |
34 | It is used by the program t-mouse.") | |
35 | ||
36 | (defvar t-mouse-filter-accumulator "" | |
37 | "Accumulates input from the mouse reporting process.") | |
38 | ||
39 | (defvar t-mouse-debug-buffer nil | |
40 | "Events normally posted to command queue are printed here in debug mode. | |
41 | See `t-mouse-start-debug'.") | |
42 | ||
43 | (defvar t-mouse-current-xy '(0 . 0) | |
44 | "Stores the last mouse position t-mouse has been told about.") | |
45 | ||
46 | (defvar t-mouse-drag-start nil | |
47 | "Whenever a drag starts in a special part of a window | |
48 | (not the text), the `translated' starting coordinates including the | |
49 | window and part involved are saved here. This is necessary lest they | |
50 | get re-translated when the button goes up, at which time window | |
51 | configuration may have changed.") | |
52 | ||
53 | (defvar t-mouse-prev-set-selection-function 'x-set-selection) | |
54 | (defvar t-mouse-prev-get-selection-function 'x-get-selection) | |
55 | ||
56 | (defvar t-mouse-swap-alt-keys nil | |
57 | "When set, Emacs will handle mouse events with the right Alt | |
58 | (a.k.a. Alt-Ger) modifier, not with the regular left Alt modifier. | |
59 | Useful for people who play strange games with their keyboard tables.") | |
60 | ||
61 | (defvar t-mouse-fix-21 nil | |
62 | "Enable brain-dead chords for 2 button mice.") | |
63 | ||
64 | \f | |
65 | ;;; Code: | |
66 | ||
67 | ;; get the number of the current virtual console | |
68 | ||
69 | (defun t-mouse-tty () | |
70 | "Returns number of virtual terminal Emacs is running on, as a string. | |
71 | For example, \"2\" for /dev/tty2." | |
72 | (let ((buffer (generate-new-buffer "*t-mouse*"))) | |
73 | (call-process "ps" nil buffer nil "h" (format "%s" (emacs-pid))) | |
74 | (prog1 (save-excursion | |
75 | (set-buffer buffer) | |
76 | (goto-char (point-min)) | |
77 | (if (or | |
78 | ;; Many versions of "ps", all different.... | |
79 | (re-search-forward " +tty\\(.?[0-9a-f]\\)" nil t) | |
80 | (re-search-forward "p \\([0-9a-f]\\)" nil t) | |
81 | (re-search-forward "v0\\([0-9a-f]\\)" nil t) | |
82 | (re-search-forward "[0-9]+ +\\([0-9]+\\)" nil t) | |
83 | (re-search-forward "[\\t ]*[0-9]+[\\t ]+\\([0-9]+\\)" nil t)) | |
84 | (buffer-substring (match-beginning 1) (match-end 1)))) | |
85 | (kill-buffer buffer)))) | |
86 | ||
87 | \f | |
88 | ;; due to a horrible kludge in Emacs' keymap handler | |
89 | ;; (read_key_sequence) mouse clicks on funny parts of windows generate | |
90 | ;; TWO events, the first being a dummy of the sort '(mode-line). | |
91 | ;; That's why Per Abrahamsen's code in xt-mouse.el doesn't work for | |
92 | ;; the modeline, for instance. | |
93 | ||
94 | ;; now get this: the Emacs C code that generates these fake events | |
95 | ;; depends on certain things done by the very lowest level input | |
96 | ;; handlers; namely the symbols for the events (for instance | |
97 | ;; 'C-S-double-mouse-2) must have an 'event-kind property, set to | |
98 | ;; 'mouse-click. Since events from unread-command-events do not pass | |
99 | ;; through the low level handlers, they don't get this property unless | |
100 | ;; I set it myself. I imagine this has caused innumerable attempts by | |
101 | ;; hackers to do things similar to t-mouse to lose. | |
102 | ||
103 | ;; The next page of code is devoted to fixing this ugly problem. | |
104 | ||
105 | ;; WOW! a fully general powerset generator | |
106 | ;; (C) Ian Zimmerman Mon Mar 23 12:00:16 PST 1998 :-) | |
107 | (defun t-mouse-powerset (l) | |
108 | (if (null l) '(nil) | |
109 | (let ((l1 (t-mouse-powerset (cdr l))) | |
110 | (first (nth 0 l))) | |
111 | (append | |
112 | (mapcar (function (lambda (l) (cons first l))) l1) l1)))) | |
113 | ||
114 | ;; and a slightly less general cartesian product | |
115 | (defun t-mouse-cartesian (l1 l2) | |
116 | (if (null l1) l2 | |
117 | (append (mapcar (function (lambda (x) (append (nth 0 l1) x))) l2) | |
118 | (t-mouse-cartesian (cdr l1) l2)))) | |
119 | ||
120 | (let* ((modifier-sets (t-mouse-powerset '(control meta shift))) | |
121 | (typed-sets (t-mouse-cartesian '((down) (drag)) | |
122 | '((mouse-1) (mouse-2) (mouse-3)))) | |
123 | (multipled-sets (t-mouse-cartesian '((double) (triple)) typed-sets)) | |
124 | (all-sets (t-mouse-cartesian modifier-sets multipled-sets))) | |
125 | (while all-sets | |
126 | (let ((event-sym (event-convert-list (nth 0 all-sets)))) | |
127 | (if (not (get event-sym 'event-kind)) | |
128 | (put event-sym 'event-kind 'mouse-click))) | |
129 | (setq all-sets (cdr all-sets)))) | |
130 | ||
131 | \f | |
132 | ;;; This fun is partly Copyright (C) 1994 Per Abrahamsen <abraham@iesd.auc.dk> | |
133 | ;; This is basically a feeble attempt to mimic what the c function | |
134 | ;; buffer_posn_from_coords in dispnew.c does. I wish that function | |
135 | ;; were exported to Lisp. | |
136 | ||
137 | (defun t-mouse-lispy-buffer-posn-from-coords (w col line) | |
138 | "Return buffer position of character at COL and LINE within window W. | |
139 | COL and LINE are glyph coordinates, relative to W topleft corner." | |
140 | (save-window-excursion | |
141 | (select-window w) | |
142 | (save-excursion | |
143 | (move-to-window-line line) | |
144 | (move-to-column (+ col (current-column) | |
145 | (if (not (window-minibuffer-p w)) 0 | |
146 | (- (minibuffer-prompt-width))) | |
147 | (max 0 (1- (window-hscroll))))) | |
148 | (point)))) | |
149 | ||
150 | ;; compute one element of the form (WINDOW BUFFERPOS (COL . ROW) TIMESTAMP) | |
151 | ||
152 | (defun t-mouse-make-event-element (x-dot-y-avec-time) | |
153 | (let* ((x-dot-y (nth 0 x-dot-y-avec-time)) | |
154 | (x (car x-dot-y)) | |
155 | (y (cdr x-dot-y)) | |
156 | (timestamp (nth 1 x-dot-y-avec-time)) | |
157 | (w (window-at x y)) | |
158 | (left-top-right-bottom (window-edges w)) | |
159 | (left (nth 0 left-top-right-bottom)) | |
160 | (top (nth 1 left-top-right-bottom)) | |
161 | (right (nth 2 left-top-right-bottom)) | |
162 | (bottom (nth 3 left-top-right-bottom)) | |
163 | (coords-or-part (coordinates-in-window-p x-dot-y w))) | |
164 | (cond | |
165 | ((consp coords-or-part) | |
166 | (let ((wx (car coords-or-part)) (wy (cdr coords-or-part))) | |
167 | (if (< wx (- right left 1)) | |
168 | (list w | |
169 | (t-mouse-lispy-buffer-posn-from-coords w wx wy) | |
170 | coords-or-part timestamp) | |
171 | (list w 'vertical-scroll-bar | |
172 | (cons (1+ wy) (- bottom top)) timestamp)))) | |
173 | ((eq coords-or-part 'mode-line) | |
174 | (list w 'mode-line (cons (- x left) 0) timestamp)) | |
175 | ((eq coords-or-part 'vertical-line) | |
176 | (list w 'vertical-line (cons 0 (- y top)) timestamp))))) | |
177 | ||
178 | ;;; This fun is partly Copyright (C) 1994 Per Abrahamsen <abraham@iesd.auc.dk> | |
179 | ||
180 | (defun t-mouse-make-event () | |
181 | "Makes a Lisp style event from the contents of mouse input accumulator. | |
182 | Also trims the accumulator by all the data used to build the event." | |
183 | (let (ob (ob-pos (condition-case nil | |
184 | (read-from-string t-mouse-filter-accumulator) | |
185 | (error nil)))) | |
186 | (if (not ob-pos) nil | |
187 | (setq ob (car ob-pos)) | |
188 | (setq t-mouse-filter-accumulator | |
189 | (substring t-mouse-filter-accumulator (cdr ob-pos))) | |
190 | ||
191 | ;;now the real work | |
192 | ||
193 | (let ((event-type (nth 0 ob)) | |
194 | (current-xy-avec-time (nth 1 ob)) | |
195 | (type-switch (length ob))) | |
196 | ||
197 | (if t-mouse-fix-21 | |
198 | (let | |
199 | ;;Acquire the event's symbol's name. | |
200 | ((event-name-string (symbol-name event-type)) | |
201 | end-of-root-event-name | |
202 | new-event-name-string) | |
203 | ||
204 | (if (string-match "-\\(21\\|\\12\\)$" event-name-string) | |
205 | ||
206 | ;;Transform the name to what it should have been. | |
207 | (progn | |
208 | (setq end-of-root-event-name (match-beginning 0)) | |
209 | (setq new-event-name-string | |
210 | (concat (substring | |
211 | event-name-string 0 | |
212 | end-of-root-event-name) "-3")) | |
213 | ||
214 | ;;Change the event to the symbol that corresponds to the | |
215 | ;;name we made. The proper symbol already exists. | |
216 | (setq event-type | |
217 | (intern new-event-name-string)))))) | |
218 | ||
219 | ;;store current position for mouse-position | |
220 | ||
221 | (setq t-mouse-current-xy (nth 0 current-xy-avec-time)) | |
222 | ||
223 | ;;events have many types but fortunately they differ in length | |
224 | ||
225 | (cond | |
226 | ;;sink all events on the stupid text mode menubar. | |
227 | ((and menu-bar-mode (eq 0 (cdr t-mouse-current-xy))) nil) | |
228 | ((= type-switch 4) ;must be drag | |
229 | (let ((count (nth 2 ob)) | |
230 | (start-element | |
231 | (or t-mouse-drag-start | |
232 | (t-mouse-make-event-element (nth 3 ob)))) | |
233 | (end-element | |
234 | (t-mouse-make-event-element current-xy-avec-time))) | |
235 | (setq t-mouse-drag-start nil) | |
236 | (list event-type start-element end-element count))) | |
237 | ((= type-switch 3) ;down or up | |
238 | (let ((count (nth 2 ob)) | |
239 | (element | |
240 | (t-mouse-make-event-element current-xy-avec-time))) | |
241 | (if (and (not t-mouse-drag-start) | |
242 | (symbolp (nth 1 element))) | |
243 | ;; OUCH! GOTCHA! emacs uses setc[ad]r on these! | |
244 | (setq t-mouse-drag-start (copy-sequence element)) | |
245 | (setq t-mouse-drag-start nil)) | |
246 | (list event-type element count))) | |
247 | ((= type-switch 2) ;movement | |
248 | (list (if (eq 'vertical-scroll-bar | |
249 | (nth 1 t-mouse-drag-start)) 'scroll-bar-movement | |
250 | 'mouse-movement) | |
251 | (t-mouse-make-event-element current-xy-avec-time)))))))) | |
252 | ||
253 | ||
254 | (defun t-mouse-process-filter (proc string) | |
255 | (setq t-mouse-filter-accumulator | |
256 | (concat t-mouse-filter-accumulator string)) | |
257 | (let ((event (t-mouse-make-event))) | |
258 | (while event | |
259 | (if (or track-mouse | |
260 | (not (eq 'mouse-movement (event-basic-type event)))) | |
261 | (setq unread-command-events | |
262 | (nconc unread-command-events (list event)))) | |
263 | (if t-mouse-debug-buffer | |
264 | (print unread-command-events t-mouse-debug-buffer)) | |
265 | (setq event (t-mouse-make-event))))) | |
266 | ||
267 | ||
268 | ;; this overrides a C function which stupidly assumes (no X => no mouse) | |
269 | (defadvice mouse-position (around t-mouse-mouse-position activate) | |
270 | "Return the t-mouse-position unless running with a window system. | |
271 | The (secret) scrollbar interface is not implemented yet." | |
272 | (if (not window-system) | |
273 | (setq ad-return-value | |
274 | (cons (selected-frame) t-mouse-current-xy)) | |
275 | ad-do-it)) | |
276 | ||
277 | (setq mouse-sel-set-selection-function | |
278 | (function (lambda (type value) | |
279 | (if (not window-system) | |
280 | (if (eq 'PRIMARY type) (kill-new value)) | |
281 | (funcall t-mouse-prev-set-selection-function | |
282 | type value))))) | |
283 | ||
284 | (setq mouse-sel-get-selection-function | |
285 | (function (lambda (type) | |
286 | (if (not window-system) | |
287 | (if (eq 'PRIMARY type) | |
288 | (current-kill 0) "") | |
289 | (funcall t-mouse-prev-get-selection-function type))))) | |
290 | ||
291 | ;; It should be possible to just send SIGTSTP to the inferior with | |
292 | ;; stop-process. That doesn't work; mev receives the signal fine but | |
293 | ;; is not really stopped: instead it returns from | |
294 | ;; kill(getpid(), SIGTSTP) immediately. I don't understand what's up | |
295 | ;; itz Tue Mar 24 14:27:38 PST 1998. | |
296 | ||
297 | (add-hook 'suspend-hook | |
298 | (function (lambda () | |
299 | (and t-mouse-process | |
300 | ;(stop-process t-mouse-process) | |
301 | (process-send-string | |
302 | t-mouse-process "push -enone -dall -Mnone\n"))))) | |
303 | ||
304 | (add-hook 'suspend-resume-hook | |
305 | (function (lambda () | |
306 | (and t-mouse-process | |
307 | ;(continue-process t-mouse-process) | |
308 | (process-send-string t-mouse-process "pop\n"))))) | |
309 | ||
310 | \f | |
311 | ;;; User commands | |
312 | ||
313 | (defun t-mouse-stop () | |
314 | "Stop getting mouse events from an asynchronous process." | |
315 | (interactive) | |
316 | (delete-process t-mouse-process) | |
317 | (setq t-mouse-process nil)) | |
318 | ||
319 | (defun t-mouse-run () | |
320 | "Starts getting a stream of mouse events from an asynchronous process. | |
321 | Only works if Emacs is running on a virtual terminal without a window system. | |
322 | Returns the newly created asynchronous process." | |
323 | (interactive) | |
324 | (let ((tty (t-mouse-tty)) | |
325 | (process-connection-type t)) | |
326 | (if (or window-system (not (stringp tty))) | |
327 | (error "Run t-mouse on a virtual terminal without a window system")) | |
328 | (setq t-mouse-process | |
329 | (start-process "t-mouse" nil | |
330 | "mev" "-i" "-E" "-C" tty | |
331 | (if t-mouse-swap-alt-keys | |
332 | "-M-leftAlt" "-M-rightAlt") | |
333 | "-e-move" "-dall" "-d-hard" | |
334 | "-f"))) | |
335 | (setq t-mouse-filter-accumulator "") | |
336 | (set-process-filter t-mouse-process 't-mouse-process-filter) | |
337 | (process-kill-without-query t-mouse-process) | |
338 | t-mouse-process) | |
339 | ||
340 | (provide 't-mouse) | |
341 | ||
342 | ;;; t-mouse.el ends here |