1 ;; Mouse support that is independent of window systems.
2 ;; Copyright (C) 1988 Free Software Foundation, Inc.
4 ;; This file is part of GNU Emacs.
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)
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.
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.
23 (defun mouse-select ()
24 "Select Emacs window the mouse is on."
27 (defun mouse-delete-window ()
28 "Delete the Emacs window the mouse is on."
32 (defun mouse-keep-one-window ()
33 "Select Emacs window mouse is on, then kill all other Emacs windows."
35 (delete-other-windows))
37 (defun mouse-select-and-split ()
38 "Select Emacs window mouse is on, then split it vertically in half."
40 (split-window-vertically nil
))
42 (defun mouse-set-point (event)
43 "Select Emacs window mouse is on, and move point to mouse position."
45 (let ((relative-coordinate
46 (coordinates-in-window-p (car event
) (selected-window))))
47 (if (consp relative-coordinate
)
49 (move-to-window-line (car (cdr relative-coordinate
)))
50 ;; Note that hscroll must get above 1
51 ;; before the text actually starts to move.
52 (move-to-column (+ (car relative-coordinate
) (current-column)
53 (1- (max 1 (window-hscroll (selected-window))))))
56 (defun mouse-eval-last-sexpr (event)
59 (mouse-set-point event
)
60 (eval-last-sexp nil
)))
62 (defun mouse-line-length (event)
63 "Print the length of the line indicated by the pointer."
65 (let ((relative-coordinate
66 (coordinates-in-window-p (car event
) (selected-window))))
67 (if (consp relative-coordinate
)
69 (move-to-window-line (car (cdr relative-coordinate
)))
73 (message "Line length: %d"
74 (- (region-end) (region-beginning)))
77 (defun mouse-set-mark (event)
78 "Select Emacs window mouse is on, and set mark at mouse position.
79 Display cursor at that position for a second."
81 (let ((point-save (point)))
83 (progn (mouse-set-point event
)
86 (goto-char point-save
))))
88 (defun mouse-scroll (event)
89 "Scroll point to the mouse position."
91 (let ((relative-coordinate
92 (coordinates-in-window-p (car event
) (selected-window))))
93 (if (consp relative-coordinate
)
95 (recenter (car (cdr relative-coordinate
)))
96 (scroll-right (+ (car relative-coordinate
) (current-column)))))))
98 (defun mouse-del-char (event)
99 "Delete the char pointed to by the mouse."
101 (let ((relative-coordinate
102 (coordinates-in-window-p (car event
) (selected-window))))
103 (if (consp relative-coordinate
)
105 (move-to-window-line (car (cdr relative-coordinate
)))
106 (move-to-column (+ (car relative-coordinate
) (current-column)))
107 (delete-char 1 nil
)))))
109 (defun mouse-kill-line (event)
110 "Kill the line pointed to by the mouse."
112 (let ((relative-coordinate
113 (coordinates-in-window-p (car event
) (selected-window))))
114 (if (consp relative-coordinate
)
116 (move-to-window-line (car (cdr relative-coordinate
)))
117 (move-to-column (+ (car relative-coordinate
) (current-column)))
120 (defun narrow-window-to-region (m n
)
121 "Narrow window to region between point and last mark"
125 (if (eq (selected-window) (next-window))
129 (if (eq (selected-window)
130 (if (zerop (minibuffer-depth))
133 (shrink-window (- (- (window-height) (count-lines m n
)) 1))))))
135 (defun mouse-window-to-region (event)
136 "Narrow window to region between cursor and mouse pointer."
138 (let ((point-save (point)))
140 (progn (mouse-set-point event
)
143 (goto-char point-save
)
144 (narrow-window-to-region (region-beginning) (region-end)))))
146 (defun mouse-ignore ()
150 ;; Commands for the scroll bar.
152 (defun mouse-scroll-down (nlines)
154 (scroll-down nlines
))
156 (defun mouse-scroll-up (nlines)
160 (defun mouse-scroll-down-full ()
164 (defun mouse-scroll-up-full ()
168 (defun mouse-scroll-move-cursor (nlines)
170 (move-to-window-line nlines
))
172 (defun mouse-scroll-absolute (event)
174 (let* ((pos (car event
))
176 (length (car (cdr pos
))))
177 (if (<= length
0) (setq length
1))
178 (let* ((scale-factor (max 1 (/ length
(/ 8000000 (buffer-size)))))
179 (newpos (* (/ (* (/ (buffer-size) scale-factor
)
186 (defun mouse-scroll-left (ncolumns)
188 (scroll-left ncolumns
))
190 (defun mouse-scroll-right (ncolumns)
192 (scroll-right ncolumns
))
194 (defun mouse-scroll-left-full ()
198 (defun mouse-scroll-right-full ()
202 (defun mouse-scroll-move-cursor-horizontally (ncolumns)
204 (move-to-column ncolumns
))
206 (defun mouse-scroll-absolute-horizontally (event)
208 (let* ((pos (car event
))
210 (length (car (cdr pos
))))
211 (set-window-hscroll (selected-window) 33)))
213 ;; Set up these commands, including the prefix keys for the scroll bar.
215 (fset 'mouse-vertical-scroll-bar-prefix
(make-sparse-keymap))
216 (define-key global-mouse-map mouse-vertical-scroll-bar-prefix
217 'mouse-vertical-scroll-bar-prefix
)
219 (defun mouse-scroll-motion (event)
221 (let ((pos (car (car event
)))
222 (length (car (cdr (car event
)))))
223 (message "[%d %d]" pos length
)))
225 (let ((map (function mouse-vertical-scroll-bar-prefix
)))
226 (define-key map mouse-button-right
'mouse-scroll-down
)
227 (define-key map mouse-button-left
'mouse-scroll-up
)
228 (define-key map mouse-button-middle
'mouse-scroll-absolute
)
229 (define-key map mouse-motion
'x-horizontal-line
))
231 ;(fset 'mouse-vertical-slider-prefix (make-sparse-keymap))
232 ;(define-key global-mouse-map mouse-vertical-slider-prefix
233 ; 'mouse-vertical-slider-prefix)
235 ;(let ((map (function mouse-vertical-slider-prefix)))
236 ; (define-key map mouse-button-right 'mouse-scroll-move-cursor)
237 ; (define-key map mouse-button-left 'mouse-scroll-move-cursor)
238 ; (define-key map mouse-button-middle 'mouse-scroll-move-cursor))
240 (fset 'mouse-vertical-thumbup-prefix
(make-sparse-keymap))
241 (define-key global-mouse-map mouse-vertical-thumbup-prefix
242 'mouse-vertical-thumbup-prefix
)
244 (let ((map (function mouse-vertical-thumbup-prefix
)))
245 (define-key map mouse-button-right
'mouse-scroll-down-full
)
246 (define-key map mouse-button-left
'mouse-scroll-down-full
)
247 (define-key map mouse-button-middle
'mouse-scroll-down-full
))
249 (fset 'mouse-vertical-thumbdown-prefix
(make-sparse-keymap))
250 (define-key global-mouse-map mouse-vertical-thumbdown-prefix
251 'mouse-vertical-thumbdown-prefix
)
253 (let ((map (function mouse-vertical-thumbdown-prefix
)))
254 (define-key map mouse-button-right
'mouse-scroll-up-full
)
255 (define-key map mouse-button-left
'mouse-scroll-up-full
)
256 (define-key map mouse-button-middle
'mouse-scroll-up-full
))
260 (fset 'mouse-horizontal-scroll-bar-prefix
(make-sparse-keymap))
261 (define-key global-mouse-map mouse-horizontal-scroll-bar-prefix
262 'mouse-horizontal-scroll-bar-prefix
)
264 (let ((map (function mouse-horizontal-scroll-bar-prefix
)))
265 (define-key map mouse-button-right
'mouse-scroll-right
)
266 (define-key map mouse-button-left
'mouse-scroll-left
)
267 (define-key map mouse-button-middle
'mouse-scroll-absolute-horizontally
))
269 (fset 'mouse-horizontal-thumbleft-prefix
(make-sparse-keymap))
270 (define-key global-mouse-map mouse-horizontal-thumbleft-prefix
271 'mouse-horizontal-thumbleft-prefix
)
273 (let ((map (function mouse-horizontal-thumbleft-prefix
)))
274 (define-key map mouse-button-right
'mouse-scroll-left-full
)
275 (define-key map mouse-button-left
'mouse-scroll-left-full
)
276 (define-key map mouse-button-middle
'mouse-scroll-left-full
))
278 (fset 'mouse-horizontal-thumbright-prefix
(make-sparse-keymap))
279 (define-key global-mouse-map mouse-horizontal-thumbright-prefix
280 'mouse-horizontal-thumbright-prefix
)
282 (let ((map (function mouse-horizontal-thumbright-prefix
)))
283 (define-key map mouse-button-right
'mouse-scroll-right-full
)
284 (define-key map mouse-button-left
'mouse-scroll-right-full
)
285 (define-key map mouse-button-middle
'mouse-scroll-right-full
))
289 ;; Here are experimental things being tested. Mouse events
291 ;; ((x y) window screen-part key-sequence timestamp)
294 ;; Dynamically track mouse coordinates
297 (defun track-mouse (event)
298 "Track the coordinates, absolute and relative, of the mouse."
301 (let* ((pos (read-mouse-position (selected-screen)))
304 (relative-coordinate (coordinates-in-window-p
305 (list (car pos
) (cdr pos
))
307 (if (consp relative-coordinate
)
308 (message "mouse: [%d %d], (%d %d)" abs-x abs-y
309 (car relative-coordinate
)
310 (car (cdr relative-coordinate
)))
311 (message "mouse: [%d %d]" abs-x abs-y
)))))
314 ;; Dynamically put a box around the line indicated by point
319 (defun mouse-select-buffer-line (event)
321 (let ((relative-coordinate
322 (coordinates-in-window-p (car event
) (selected-window)))
323 (abs-y (car (cdr (car event
)))))
324 (if (consp relative-coordinate
)
327 (move-to-window-line (car (cdr relative-coordinate
)))
332 (move-to-window-line (car (cdr relative-coordinate
)))
336 (- (region-end) (region-beginning))) 1)
337 (setq the-buffer
(Buffer-menu-buffer t
)))
339 (x-erase-rectangle (selected-screen))))))
341 (defvar last-line-drawn nil
)
342 (defvar begin-delim
"[^ \t]")
343 (defvar end-delim
"[^ \t]")
345 (defun mouse-boxing (event)
348 (let ((screen (selected-screen)))
349 (while (= (x-mouse-events) 0)
350 (let* ((pos (read-mouse-position screen
))
354 (coordinates-in-window-p (` ((, abs-x
) (, abs-y
)))
360 (if (and (consp relative-coordinate
)
361 (or (not last-line-drawn
)
362 (not (= last-line-drawn abs-y
))))
364 (move-to-window-line (car (cdr relative-coordinate
)))
365 (if (= (following-char) 10)
368 (setq begin-reg
(1- (re-search-forward end-delim
)))
369 (setq begin-column
(1- (current-column)))
371 (setq end-reg
(1+ (re-search-backward begin-delim
)))
372 (setq end-column
(1+ (current-column)))
373 (message "%s" (buffer-substring begin-reg end-reg
))
374 (x-draw-rectangle screen
375 (setq last-line-drawn abs-y
)
377 (- end-column begin-column
) 1))))))))))
379 (defun mouse-erase-box ()
383 (x-erase-rectangle (selected-screen))
384 (setq last-line-drawn nil
))))
386 (defun test-x-rectangle ()
387 (use-local-mouse-map (setq rectangle-test-map
(make-sparse-keymap)))
388 (define-key rectangle-test-map mouse-motion-button-left
'mouse-boxing
)
389 (define-key rectangle-test-map mouse-button-left-up
'mouse-erase-box
))
392 ;; Here is how to do double clicking in lisp. About to change.
395 (defvar double-start nil
)
396 (defconst double-click-interval
300
397 "Max ticks between clicks")
399 (defun double-down (event)
402 (let ((interval (- (nth 4 event
) double-start
)))
403 (if (< interval double-click-interval
)
406 ;; (message "Interval %d" interval)
408 (setq double-start nil
))
409 (setq double-start
(nth 4 event
))))
411 (defun double-up (event)
414 (> (- (nth 4 event
) double-start
) double-click-interval
)
415 (setq double-start nil
)))
417 (defun x-test-doubleclick ()
418 (use-local-mouse-map (setq doubleclick-test-map
(make-sparse-keymap)))
419 (define-key doubleclick-test-map mouse-button-left
'double-down
)
420 (define-key doubleclick-test-map mouse-button-left-up
'double-up
))
423 ;; This scrolls while button is depressed. Use preferable in scrollbar.
426 (defvar scrolled-lines
0)
427 (defconst scroll-speed
1)
429 (defun incr-scroll-down (event)
431 (setq scrolled-lines
0)
432 (incremental-scroll scroll-speed
))
434 (defun incr-scroll-up (event)
436 (setq scrolled-lines
0)
437 (incremental-scroll (- scroll-speed
)))
439 (defun incremental-scroll (n)
440 (while (= (x-mouse-events) 0)
441 (setq scrolled-lines
(1+ (* scroll-speed scrolled-lines
)))
445 (defun incr-scroll-stop (event)
447 (message "Scrolled %d lines" scrolled-lines
)
448 (setq scrolled-lines
0)
451 (defun x-testing-scroll ()
452 (let ((scrolling-map (function mouse-vertical-scroll-bar-prefix
)))
453 (define-key scrolling-map mouse-button-left
'incr-scroll-down
)
454 (define-key scrolling-map mouse-button-right
'incr-scroll-up
)
455 (define-key scrolling-map mouse-button-left-up
'incr-scroll-stop
)
456 (define-key scrolling-map mouse-button-right-up
'incr-scroll-stop
)))
459 ;; Some playthings suitable for picture mode? They need work.
462 (defun mouse-kill-rectangle (event)
463 "Kill the rectangle between point and the mouse cursor."
465 (let ((point-save (point)))
467 (mouse-set-point event
)
469 (if (> point-save
(point))
470 (kill-rectangle (point) point-save
)
471 (kill-rectangle point-save
(point))))))
473 (defun mouse-open-rectangle (event)
474 "Kill the rectangle between point and the mouse cursor."
476 (let ((point-save (point)))
478 (mouse-set-point event
)
480 (if (> point-save
(point))
481 (open-rectangle (point) point-save
)
482 (open-rectangle point-save
(point))))))
484 ;; Must be a better way to do this.
486 (defun mouse-multiple-insert (n char
)
491 ;; What this could do is not finalize until button was released.
493 (defun mouse-move-text (event)
494 "Move text from point to cursor position, inserting spaces."
496 (let* ((relative-coordinate
497 (coordinates-in-window-p (car event
) (selected-window))))
498 (if (consp relative-coordinate
)
499 (cond ((> (current-column) (car relative-coordinate
))
501 (- (car relative-coordinate
) (current-column))))
502 ((< (current-column) (car relative-coordinate
))
503 (mouse-multiple-insert
504 (- (car relative-coordinate
) (current-column)) " "))
505 ((= (current-column) (car relative-coordinate
)) (ding))))))