Commit | Line | Data |
---|---|---|
72ea54a4 RS |
1 | ;; Mouse support that is independent of window systems. |
2 | ;; Copyright (C) 1988 Free Software Foundation, Inc. | |
3 | ||
4 | ;; This file is part of GNU Emacs. | |
5 | ||
6 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
7 | ;; it under the terms of the GNU General Public License as published by | |
8 | ;; the Free Software Foundation; either version 1, or (at your option) | |
9 | ;; any later version. | |
10 | ||
11 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
12 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;; GNU General Public License for more details. | |
15 | ||
16 | ;; You should have received a copy of the GNU General Public License | |
17 | ;; along with GNU Emacs; see the file COPYING. If not, write to | |
18 | ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
19 | ||
20 | (provide 'mouse) | |
21 | ||
22 | \f | |
23 | (defun mouse-select () | |
24 | "Select Emacs window the mouse is on." | |
25 | (interactive "@")) | |
26 | ||
27 | (defun mouse-delete-window () | |
28 | "Delete the Emacs window the mouse is on." | |
29 | (interactive "@") | |
30 | (delete-window)) | |
31 | ||
32 | (defun mouse-keep-one-window () | |
33 | "Select Emacs window mouse is on, then kill all other Emacs windows." | |
34 | (interactive "@") | |
35 | (delete-other-windows)) | |
36 | ||
37 | (defun mouse-select-and-split () | |
38 | "Select Emacs window mouse is on, then split it vertically in half." | |
39 | (interactive "@") | |
40 | (split-window-vertically nil)) | |
41 | ||
42 | (defun mouse-set-point (event) | |
43 | "Select Emacs window mouse is on, and move point to mouse position." | |
44 | (interactive "@e") | |
45 | (let ((relative-coordinate | |
46 | (coordinates-in-window-p (car event) (selected-window)))) | |
47 | (if (consp relative-coordinate) | |
48 | (progn | |
49 | (move-to-window-line (car (cdr relative-coordinate))) | |
50 | (move-to-column (+ (car relative-coordinate) (current-column) | |
51 | (window-hscroll (selected-window)))) | |
52 | (what-line))))) | |
53 | ||
54 | (defun mouse-eval-last-sexpr (event) | |
55 | (interactive "@e") | |
56 | (save-excursion | |
57 | (mouse-set-point event) | |
58 | (eval-last-sexp nil))) | |
59 | ||
60 | (defun mouse-line-length (event) | |
61 | "Print the length of the line indicated by the pointer." | |
62 | (interactive "@e") | |
63 | (let ((relative-coordinate | |
64 | (coordinates-in-window-p (car event) (selected-window)))) | |
65 | (if (consp relative-coordinate) | |
66 | (save-excursion | |
67 | (move-to-window-line (car (cdr relative-coordinate))) | |
68 | (end-of-line) | |
69 | (push-mark nil t) | |
70 | (beginning-of-line) | |
71 | (message "Line length: %d" | |
72 | (- (region-end) (region-beginning))) | |
73 | (sleep-for 1))))) | |
74 | ||
75 | (defun mouse-set-mark (event) | |
76 | "Select Emacs window mouse is on, and set mark at mouse position. | |
77 | Display cursor at that position for a second." | |
78 | (interactive "@e") | |
79 | (let ((point-save (point))) | |
80 | (unwind-protect | |
81 | (progn (mouse-set-point event) | |
82 | (push-mark nil t) | |
83 | (sleep-for 1)) | |
84 | (goto-char point-save)))) | |
85 | ||
86 | (defun mouse-scroll (event) | |
87 | "Scroll point to the mouse position." | |
88 | (interactive "@e") | |
89 | (let ((relative-coordinate | |
90 | (coordinates-in-window-p (car event) (selected-window)))) | |
91 | (if (consp relative-coordinate) | |
92 | (progn | |
93 | (recenter (car (cdr relative-coordinate))) | |
94 | (scroll-right (+ (car relative-coordinate) (current-column))))))) | |
95 | ||
96 | (defun mouse-del-char (event) | |
97 | "Delete the char pointed to by the mouse." | |
98 | (interactive "@e") | |
99 | (let ((relative-coordinate | |
100 | (coordinates-in-window-p (car event) (selected-window)))) | |
101 | (if (consp relative-coordinate) | |
102 | (progn | |
103 | (move-to-window-line (car (cdr relative-coordinate))) | |
104 | (move-to-column (+ (car relative-coordinate) (current-column))) | |
105 | (delete-char 1 nil))))) | |
106 | ||
107 | (defun mouse-kill-line (event) | |
108 | "Kill the line pointed to by the mouse." | |
109 | (interactive "@e") | |
110 | (let ((relative-coordinate | |
111 | (coordinates-in-window-p (car event) (selected-window)))) | |
112 | (if (consp relative-coordinate) | |
113 | (progn | |
114 | (move-to-window-line (car (cdr relative-coordinate))) | |
115 | (move-to-column (+ (car relative-coordinate) (current-column))) | |
116 | (kill-line nil))))) | |
117 | ||
118 | (defun narrow-window-to-region (m n) | |
119 | "Narrow window to region between point and last mark" | |
120 | (interactive "r") | |
121 | (save-excursion | |
122 | (save-restriction | |
123 | (if (eq (selected-window) (next-window)) | |
124 | (split-window)) | |
125 | (goto-char m) | |
126 | (recenter 0) | |
127 | (if (eq (selected-window) | |
128 | (if (zerop (minibuffer-depth)) | |
129 | (next-window))) | |
130 | () | |
131 | (shrink-window (- (- (window-height) (count-lines m n)) 1)))))) | |
132 | ||
133 | (defun mouse-window-to-region (event) | |
134 | "Narrow window to region between cursor and mouse pointer." | |
135 | (interactive "@e") | |
136 | (let ((point-save (point))) | |
137 | (unwind-protect | |
138 | (progn (mouse-set-point event) | |
139 | (push-mark nil t) | |
140 | (sit-for 1)) | |
141 | (goto-char point-save) | |
142 | (narrow-window-to-region (region-beginning) (region-end))))) | |
143 | ||
144 | (defun mouse-ignore () | |
145 | "Don't do anything." | |
146 | (interactive)) | |
147 | \f | |
148 | ;; Commands for the scroll bar. | |
149 | ||
150 | (defun mouse-scroll-down (nlines) | |
151 | (interactive "@p") | |
152 | (scroll-down nlines)) | |
153 | ||
154 | (defun mouse-scroll-up (nlines) | |
155 | (interactive "@p") | |
156 | (scroll-up nlines)) | |
157 | ||
158 | (defun mouse-scroll-down-full () | |
159 | (interactive "@") | |
160 | (scroll-down nil)) | |
161 | ||
162 | (defun mouse-scroll-up-full () | |
163 | (interactive "@") | |
164 | (scroll-up nil)) | |
165 | ||
166 | (defun mouse-scroll-move-cursor (nlines) | |
167 | (interactive "@p") | |
168 | (move-to-window-line nlines)) | |
169 | ||
170 | (defun mouse-scroll-absolute (event) | |
171 | (interactive "@e") | |
172 | (let* ((pos (car event)) | |
173 | (position (car pos)) | |
174 | (length (car (cdr pos)))) | |
175 | (if (<= length 0) (setq length 1)) | |
176 | (let* ((scale-factor (max 1 (/ length (/ 8000000 (buffer-size))))) | |
177 | (newpos (* (/ (* (/ (buffer-size) scale-factor) | |
178 | position) | |
179 | length) | |
180 | scale-factor))) | |
181 | (goto-char newpos) | |
182 | (recenter '(4))))) | |
183 | ||
184 | (defun mouse-scroll-left (ncolumns) | |
185 | (interactive "@p") | |
186 | (scroll-left ncolumns)) | |
187 | ||
188 | (defun mouse-scroll-right (ncolumns) | |
189 | (interactive "@p") | |
190 | (scroll-right ncolumns)) | |
191 | ||
192 | (defun mouse-scroll-left-full () | |
193 | (interactive "@") | |
194 | (scroll-left nil)) | |
195 | ||
196 | (defun mouse-scroll-right-full () | |
197 | (interactive "@") | |
198 | (scroll-right nil)) | |
199 | ||
200 | (defun mouse-scroll-move-cursor-horizontally (ncolumns) | |
201 | (interactive "@p") | |
202 | (move-to-column ncolumns)) | |
203 | ||
204 | (defun mouse-scroll-absolute-horizontally (event) | |
205 | (interactive "@e") | |
206 | (let* ((pos (car event)) | |
207 | (position (car pos)) | |
208 | (length (car (cdr pos)))) | |
209 | (set-window-hscroll (selected-window) 33))) | |
210 | ||
211 | ;; Set up these commands, including the prefix keys for the scroll bar. | |
212 | ||
213 | (fset 'mouse-vertical-scroll-bar-prefix (make-sparse-keymap)) | |
214 | (define-key global-mouse-map mouse-vertical-scroll-bar-prefix | |
215 | 'mouse-vertical-scroll-bar-prefix) | |
216 | ||
217 | (defun mouse-scroll-motion (event) | |
218 | (interactive "e") | |
219 | (let ((pos (car (car event))) | |
220 | (length (car (cdr (car event))))) | |
221 | (message "[%d %d]" pos length))) | |
222 | ||
223 | (let ((map (function mouse-vertical-scroll-bar-prefix))) | |
224 | (define-key map mouse-button-right 'mouse-scroll-down) | |
225 | (define-key map mouse-button-left 'mouse-scroll-up) | |
226 | (define-key map mouse-button-middle 'mouse-scroll-absolute) | |
227 | (define-key map mouse-motion 'x-horizontal-line)) | |
228 | ||
229 | ;(fset 'mouse-vertical-slider-prefix (make-sparse-keymap)) | |
230 | ;(define-key global-mouse-map mouse-vertical-slider-prefix | |
231 | ; 'mouse-vertical-slider-prefix) | |
232 | ||
233 | ;(let ((map (function mouse-vertical-slider-prefix))) | |
234 | ; (define-key map mouse-button-right 'mouse-scroll-move-cursor) | |
235 | ; (define-key map mouse-button-left 'mouse-scroll-move-cursor) | |
236 | ; (define-key map mouse-button-middle 'mouse-scroll-move-cursor)) | |
237 | ||
238 | (fset 'mouse-vertical-thumbup-prefix (make-sparse-keymap)) | |
239 | (define-key global-mouse-map mouse-vertical-thumbup-prefix | |
240 | 'mouse-vertical-thumbup-prefix) | |
241 | ||
242 | (let ((map (function mouse-vertical-thumbup-prefix))) | |
243 | (define-key map mouse-button-right 'mouse-scroll-down-full) | |
244 | (define-key map mouse-button-left 'mouse-scroll-down-full) | |
245 | (define-key map mouse-button-middle 'mouse-scroll-down-full)) | |
246 | ||
247 | (fset 'mouse-vertical-thumbdown-prefix (make-sparse-keymap)) | |
248 | (define-key global-mouse-map mouse-vertical-thumbdown-prefix | |
249 | 'mouse-vertical-thumbdown-prefix) | |
250 | ||
251 | (let ((map (function mouse-vertical-thumbdown-prefix))) | |
252 | (define-key map mouse-button-right 'mouse-scroll-up-full) | |
253 | (define-key map mouse-button-left 'mouse-scroll-up-full) | |
254 | (define-key map mouse-button-middle 'mouse-scroll-up-full)) | |
255 | ||
256 | ;; Horizontal bar | |
257 | ||
258 | (fset 'mouse-horizontal-scroll-bar-prefix (make-sparse-keymap)) | |
259 | (define-key global-mouse-map mouse-horizontal-scroll-bar-prefix | |
260 | 'mouse-horizontal-scroll-bar-prefix) | |
261 | ||
262 | (let ((map (function mouse-horizontal-scroll-bar-prefix))) | |
263 | (define-key map mouse-button-right 'mouse-scroll-right) | |
264 | (define-key map mouse-button-left 'mouse-scroll-left) | |
265 | (define-key map mouse-button-middle 'mouse-scroll-absolute-horizontally)) | |
266 | ||
267 | (fset 'mouse-horizontal-thumbleft-prefix (make-sparse-keymap)) | |
268 | (define-key global-mouse-map mouse-horizontal-thumbleft-prefix | |
269 | 'mouse-horizontal-thumbleft-prefix) | |
270 | ||
271 | (let ((map (function mouse-horizontal-thumbleft-prefix))) | |
272 | (define-key map mouse-button-right 'mouse-scroll-left-full) | |
273 | (define-key map mouse-button-left 'mouse-scroll-left-full) | |
274 | (define-key map mouse-button-middle 'mouse-scroll-left-full)) | |
275 | ||
276 | (fset 'mouse-horizontal-thumbright-prefix (make-sparse-keymap)) | |
277 | (define-key global-mouse-map mouse-horizontal-thumbright-prefix | |
278 | 'mouse-horizontal-thumbright-prefix) | |
279 | ||
280 | (let ((map (function mouse-horizontal-thumbright-prefix))) | |
281 | (define-key map mouse-button-right 'mouse-scroll-right-full) | |
282 | (define-key map mouse-button-left 'mouse-scroll-right-full) | |
283 | (define-key map mouse-button-middle 'mouse-scroll-right-full)) | |
284 | ||
285 | ||
286 | ;; | |
287 | ;; Here are experimental things being tested. Mouse events | |
288 | ;; are of the form: | |
289 | ;; ((x y) window screen-part key-sequence timestamp) | |
290 | ||
291 | ;; | |
292 | ;; Dynamically track mouse coordinates | |
293 | ;; | |
294 | ||
295 | (defun track-mouse (event) | |
296 | "Track the coordinates, absolute and relative, of the mouse." | |
297 | (interactive "@e") | |
298 | (while mouse-grabbed | |
299 | (let* ((pos (read-mouse-position (selected-screen))) | |
300 | (abs-x (car pos)) | |
301 | (abs-y (cdr pos)) | |
302 | (relative-coordinate (coordinates-in-window-p | |
303 | (list (car pos) (cdr pos)) | |
304 | (selected-window)))) | |
305 | (if (consp relative-coordinate) | |
306 | (message "mouse: [%d %d], (%d %d)" abs-x abs-y | |
307 | (car relative-coordinate) | |
308 | (car (cdr relative-coordinate))) | |
309 | (message "mouse: [%d %d]" abs-x abs-y))))) | |
310 | ||
311 | ;; | |
312 | ;; Dynamically put a box around the line indicated by point | |
313 | ;; | |
314 | ||
315 | (require 'backquote) | |
316 | ||
317 | (defun mouse-select-buffer-line (event) | |
318 | (interactive "@e") | |
319 | (let ((relative-coordinate | |
320 | (coordinates-in-window-p (car event) (selected-window))) | |
321 | (abs-y (car (cdr (car event))))) | |
322 | (if (consp relative-coordinate) | |
323 | (progn | |
324 | (save-excursion | |
325 | (move-to-window-line (car (cdr relative-coordinate))) | |
326 | (x-draw-rectangle | |
327 | (selected-screen) | |
328 | abs-y 0 | |
329 | (save-excursion | |
330 | (move-to-window-line (car (cdr relative-coordinate))) | |
331 | (end-of-line) | |
332 | (push-mark nil t) | |
333 | (beginning-of-line) | |
334 | (- (region-end) (region-beginning))) 1) | |
335 | (setq the-buffer (Buffer-menu-buffer t))) | |
336 | (sit-for 1) | |
337 | (x-erase-rectangle (selected-screen)))))) | |
338 | ||
339 | (defvar last-line-drawn nil) | |
340 | (defvar begin-delim "[^ \t]") | |
341 | (defvar end-delim "[^ \t]") | |
342 | ||
343 | (defun mouse-boxing (event) | |
344 | (interactive "@e") | |
345 | (save-excursion | |
346 | (let ((screen (selected-screen))) | |
347 | (while (= (x-mouse-events) 0) | |
348 | (let* ((pos (read-mouse-position screen)) | |
349 | (abs-x (car pos)) | |
350 | (abs-y (cdr pos)) | |
351 | (relative-coordinate | |
352 | (coordinates-in-window-p (` ((, abs-x) (, abs-y))) | |
353 | (selected-window))) | |
354 | (begin-reg nil) | |
355 | (end-reg nil) | |
356 | (end-column nil) | |
357 | (begin-column nil)) | |
358 | (if (and (consp relative-coordinate) | |
359 | (or (not last-line-drawn) | |
360 | (not (= last-line-drawn abs-y)))) | |
361 | (progn | |
362 | (move-to-window-line (car (cdr relative-coordinate))) | |
363 | (if (= (following-char) 10) | |
364 | () | |
365 | (progn | |
366 | (setq begin-reg (1- (re-search-forward end-delim))) | |
367 | (setq begin-column (1- (current-column))) | |
368 | (end-of-line) | |
369 | (setq end-reg (1+ (re-search-backward begin-delim))) | |
370 | (setq end-column (1+ (current-column))) | |
371 | (message "%s" (buffer-substring begin-reg end-reg)) | |
372 | (x-draw-rectangle screen | |
373 | (setq last-line-drawn abs-y) | |
374 | begin-column | |
375 | (- end-column begin-column) 1)))))))))) | |
376 | ||
377 | (defun mouse-erase-box () | |
378 | (interactive) | |
379 | (if last-line-drawn | |
380 | (progn | |
381 | (x-erase-rectangle (selected-screen)) | |
382 | (setq last-line-drawn nil)))) | |
383 | ||
384 | (defun test-x-rectangle () | |
385 | (use-local-mouse-map (setq rectangle-test-map (make-sparse-keymap))) | |
386 | (define-key rectangle-test-map mouse-motion-button-left 'mouse-boxing) | |
387 | (define-key rectangle-test-map mouse-button-left-up 'mouse-erase-box)) | |
388 | ||
389 | ;; | |
390 | ;; Here is how to do double clicking in lisp. About to change. | |
391 | ;; | |
392 | ||
393 | (defvar double-start nil) | |
394 | (defconst double-click-interval 300 | |
395 | "Max ticks between clicks") | |
396 | ||
397 | (defun double-down (event) | |
398 | (interactive "@e") | |
399 | (if double-start | |
400 | (let ((interval (- (nth 4 event) double-start))) | |
401 | (if (< interval double-click-interval) | |
402 | (progn | |
403 | (backward-up-list 1) | |
404 | ;; (message "Interval %d" interval) | |
405 | (sleep-for 1))) | |
406 | (setq double-start nil)) | |
407 | (setq double-start (nth 4 event)))) | |
408 | ||
409 | (defun double-up (event) | |
410 | (interactive "@e") | |
411 | (and double-start | |
412 | (> (- (nth 4 event ) double-start) double-click-interval) | |
413 | (setq double-start nil))) | |
414 | ||
415 | (defun x-test-doubleclick () | |
416 | (use-local-mouse-map (setq doubleclick-test-map (make-sparse-keymap))) | |
417 | (define-key doubleclick-test-map mouse-button-left 'double-down) | |
418 | (define-key doubleclick-test-map mouse-button-left-up 'double-up)) | |
419 | ||
420 | ;; | |
421 | ;; This scrolls while button is depressed. Use preferable in scrollbar. | |
422 | ;; | |
423 | ||
424 | (defvar scrolled-lines 0) | |
425 | (defconst scroll-speed 1) | |
426 | ||
427 | (defun incr-scroll-down (event) | |
428 | (interactive "@e") | |
429 | (setq scrolled-lines 0) | |
430 | (incremental-scroll scroll-speed)) | |
431 | ||
432 | (defun incr-scroll-up (event) | |
433 | (interactive "@e") | |
434 | (setq scrolled-lines 0) | |
435 | (incremental-scroll (- scroll-speed))) | |
436 | ||
437 | (defun incremental-scroll (n) | |
438 | (while (= (x-mouse-events) 0) | |
439 | (setq scrolled-lines (1+ (* scroll-speed scrolled-lines))) | |
440 | (scroll-down n) | |
441 | (sit-for 300 t))) | |
442 | ||
443 | (defun incr-scroll-stop (event) | |
444 | (interactive "@e") | |
445 | (message "Scrolled %d lines" scrolled-lines) | |
446 | (setq scrolled-lines 0) | |
447 | (sleep-for 1)) | |
448 | ||
449 | (defun x-testing-scroll () | |
450 | (let ((scrolling-map (function mouse-vertical-scroll-bar-prefix))) | |
451 | (define-key scrolling-map mouse-button-left 'incr-scroll-down) | |
452 | (define-key scrolling-map mouse-button-right 'incr-scroll-up) | |
453 | (define-key scrolling-map mouse-button-left-up 'incr-scroll-stop) | |
454 | (define-key scrolling-map mouse-button-right-up 'incr-scroll-stop))) | |
455 | ||
456 | ;; | |
457 | ;; Some playthings suitable for picture mode? They need work. | |
458 | ;; | |
459 | ||
460 | (defun mouse-kill-rectangle (event) | |
461 | "Kill the rectangle between point and the mouse cursor." | |
462 | (interactive "@e") | |
463 | (let ((point-save (point))) | |
464 | (save-excursion | |
465 | (mouse-set-point event) | |
466 | (push-mark nil t) | |
467 | (if (> point-save (point)) | |
468 | (kill-rectangle (point) point-save) | |
469 | (kill-rectangle point-save (point)))))) | |
470 | ||
471 | (defun mouse-open-rectangle (event) | |
472 | "Kill the rectangle between point and the mouse cursor." | |
473 | (interactive "@e") | |
474 | (let ((point-save (point))) | |
475 | (save-excursion | |
476 | (mouse-set-point event) | |
477 | (push-mark nil t) | |
478 | (if (> point-save (point)) | |
479 | (open-rectangle (point) point-save) | |
480 | (open-rectangle point-save (point)))))) | |
481 | ||
482 | ;; Must be a better way to do this. | |
483 | ||
484 | (defun mouse-multiple-insert (n char) | |
485 | (while (> n 0) | |
486 | (insert char) | |
487 | (setq n (1- n)))) | |
488 | ||
489 | ;; What this could do is not finalize until button was released. | |
490 | ||
491 | (defun mouse-move-text (event) | |
492 | "Move text from point to cursor position, inserting spaces." | |
493 | (interactive "@e") | |
494 | (let* ((relative-coordinate | |
495 | (coordinates-in-window-p (car event) (selected-window)))) | |
496 | (if (consp relative-coordinate) | |
497 | (cond ((> (current-column) (car relative-coordinate)) | |
498 | (delete-char | |
499 | (- (car relative-coordinate) (current-column)))) | |
500 | ((< (current-column) (car relative-coordinate)) | |
501 | (mouse-multiple-insert | |
502 | (- (car relative-coordinate) (current-column)) " ")) | |
503 | ((= (current-column) (car relative-coordinate)) (ding)))))) |