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 (move-to-column (+ (car relative-coordinate) (current-column)
51 (window-hscroll (selected-window))))
54 (defun mouse-eval-last-sexpr (event)
57 (mouse-set-point event)
58 (eval-last-sexp nil)))
60 (defun mouse-line-length (event)
61 "Print the length of the line indicated by the pointer."
63 (let ((relative-coordinate
64 (coordinates-in-window-p (car event) (selected-window))))
65 (if (consp relative-coordinate)
67 (move-to-window-line (car (cdr relative-coordinate)))
71 (message "Line length: %d"
72 (- (region-end) (region-beginning)))
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."
79 (let ((point-save (point)))
81 (progn (mouse-set-point event)
84 (goto-char point-save))))
86 (defun mouse-scroll (event)
87 "Scroll point to the mouse position."
89 (let ((relative-coordinate
90 (coordinates-in-window-p (car event) (selected-window))))
91 (if (consp relative-coordinate)
93 (recenter (car (cdr relative-coordinate)))
94 (scroll-right (+ (car relative-coordinate) (current-column)))))))
96 (defun mouse-del-char (event)
97 "Delete the char pointed to by the mouse."
99 (let ((relative-coordinate
100 (coordinates-in-window-p (car event) (selected-window))))
101 (if (consp relative-coordinate)
103 (move-to-window-line (car (cdr relative-coordinate)))
104 (move-to-column (+ (car relative-coordinate) (current-column)))
105 (delete-char 1 nil)))))
107 (defun mouse-kill-line (event)
108 "Kill the line pointed to by the mouse."
110 (let ((relative-coordinate
111 (coordinates-in-window-p (car event) (selected-window))))
112 (if (consp relative-coordinate)
114 (move-to-window-line (car (cdr relative-coordinate)))
115 (move-to-column (+ (car relative-coordinate) (current-column)))
118 (defun narrow-window-to-region (m n)
119 "Narrow window to region between point and last mark"
123 (if (eq (selected-window) (next-window))
127 (if (eq (selected-window)
128 (if (zerop (minibuffer-depth))
131 (shrink-window (- (- (window-height) (count-lines m n)) 1))))))
133 (defun mouse-window-to-region (event)
134 "Narrow window to region between cursor and mouse pointer."
136 (let ((point-save (point)))
138 (progn (mouse-set-point event)
141 (goto-char point-save)
142 (narrow-window-to-region (region-beginning) (region-end)))))
144 (defun mouse-ignore ()
148 ;; Commands for the scroll bar.
150 (defun mouse-scroll-down (nlines)
152 (scroll-down nlines))
154 (defun mouse-scroll-up (nlines)
158 (defun mouse-scroll-down-full ()
162 (defun mouse-scroll-up-full ()
166 (defun mouse-scroll-move-cursor (nlines)
168 (move-to-window-line nlines))
170 (defun mouse-scroll-absolute (event)
172 (let* ((pos (car event))
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)
184 (defun mouse-scroll-left (ncolumns)
186 (scroll-left ncolumns))
188 (defun mouse-scroll-right (ncolumns)
190 (scroll-right ncolumns))
192 (defun mouse-scroll-left-full ()
196 (defun mouse-scroll-right-full ()
200 (defun mouse-scroll-move-cursor-horizontally (ncolumns)
202 (move-to-column ncolumns))
204 (defun mouse-scroll-absolute-horizontally (event)
206 (let* ((pos (car event))
208 (length (car (cdr pos))))
209 (set-window-hscroll (selected-window) 33)))
211 ;; Set up these commands, including the prefix keys for the scroll bar.
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)
217 (defun mouse-scroll-motion (event)
219 (let ((pos (car (car event)))
220 (length (car (cdr (car event)))))
221 (message "[%d %d]" pos length)))
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))
229 ;(fset 'mouse-vertical-slider-prefix (make-sparse-keymap))
230 ;(define-key global-mouse-map mouse-vertical-slider-prefix
231 ; 'mouse-vertical-slider-prefix)
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))
238 (fset 'mouse-vertical-thumbup-prefix (make-sparse-keymap))
239 (define-key global-mouse-map mouse-vertical-thumbup-prefix
240 'mouse-vertical-thumbup-prefix)
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))
247 (fset 'mouse-vertical-thumbdown-prefix (make-sparse-keymap))
248 (define-key global-mouse-map mouse-vertical-thumbdown-prefix
249 'mouse-vertical-thumbdown-prefix)
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))
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)
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))
267 (fset 'mouse-horizontal-thumbleft-prefix (make-sparse-keymap))
268 (define-key global-mouse-map mouse-horizontal-thumbleft-prefix
269 'mouse-horizontal-thumbleft-prefix)
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))
276 (fset 'mouse-horizontal-thumbright-prefix (make-sparse-keymap))
277 (define-key global-mouse-map mouse-horizontal-thumbright-prefix
278 'mouse-horizontal-thumbright-prefix)
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))
287 ;; Here are experimental things being tested. Mouse events
289 ;; ((x y) window screen-part key-sequence timestamp)
292 ;; Dynamically track mouse coordinates
295 (defun track-mouse (event)
296 "Track the coordinates, absolute and relative, of the mouse."
299 (let* ((pos (read-mouse-position (selected-screen)))
302 (relative-coordinate (coordinates-in-window-p
303 (list (car pos) (cdr pos))
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)))))
312 ;; Dynamically put a box around the line indicated by point
317 (defun mouse-select-buffer-line (event)
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)
325 (move-to-window-line (car (cdr relative-coordinate)))
330 (move-to-window-line (car (cdr relative-coordinate)))
334 (- (region-end) (region-beginning))) 1)
335 (setq the-buffer (Buffer-menu-buffer t)))
337 (x-erase-rectangle (selected-screen))))))
339 (defvar last-line-drawn nil)
340 (defvar begin-delim "[^ \t]")
341 (defvar end-delim "[^ \t]")
343 (defun mouse-boxing (event)
346 (let ((screen (selected-screen)))
347 (while (= (x-mouse-events) 0)
348 (let* ((pos (read-mouse-position screen))
352 (coordinates-in-window-p (` ((, abs-x) (, abs-y)))
358 (if (and (consp relative-coordinate)
359 (or (not last-line-drawn)
360 (not (= last-line-drawn abs-y))))
362 (move-to-window-line (car (cdr relative-coordinate)))
363 (if (= (following-char) 10)
366 (setq begin-reg (1- (re-search-forward end-delim)))
367 (setq begin-column (1- (current-column)))
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)
375 (- end-column begin-column) 1))))))))))
377 (defun mouse-erase-box ()
381 (x-erase-rectangle (selected-screen))
382 (setq last-line-drawn nil))))
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))
390 ;; Here is how to do double clicking in lisp. About to change.
393 (defvar double-start nil)
394 (defconst double-click-interval 300
395 "Max ticks between clicks")
397 (defun double-down (event)
400 (let ((interval (- (nth 4 event) double-start)))
401 (if (< interval double-click-interval)
404 ;; (message "Interval %d" interval)
406 (setq double-start nil))
407 (setq double-start (nth 4 event))))
409 (defun double-up (event)
412 (> (- (nth 4 event ) double-start) double-click-interval)
413 (setq double-start nil)))
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))
421 ;; This scrolls while button is depressed. Use preferable in scrollbar.
424 (defvar scrolled-lines 0)
425 (defconst scroll-speed 1)
427 (defun incr-scroll-down (event)
429 (setq scrolled-lines 0)
430 (incremental-scroll scroll-speed))
432 (defun incr-scroll-up (event)
434 (setq scrolled-lines 0)
435 (incremental-scroll (- scroll-speed)))
437 (defun incremental-scroll (n)
438 (while (= (x-mouse-events) 0)
439 (setq scrolled-lines (1+ (* scroll-speed scrolled-lines)))
443 (defun incr-scroll-stop (event)
445 (message "Scrolled %d lines" scrolled-lines)
446 (setq scrolled-lines 0)
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)))
457 ;; Some playthings suitable for picture mode? They need work.
460 (defun mouse-kill-rectangle (event)
461 "Kill the rectangle between point and the mouse cursor."
463 (let ((point-save (point)))
465 (mouse-set-point event)
467 (if (> point-save (point))
468 (kill-rectangle (point) point-save)
469 (kill-rectangle point-save (point))))))
471 (defun mouse-open-rectangle (event)
472 "Kill the rectangle between point and the mouse cursor."
474 (let ((point-save (point)))
476 (mouse-set-point event)
478 (if (> point-save (point))
479 (open-rectangle (point) point-save)
480 (open-rectangle point-save (point))))))
482 ;; Must be a better way to do this.
484 (defun mouse-multiple-insert (n char)
489 ;; What this could do is not finalize until button was released.
491 (defun mouse-move-text (event)
492 "Move text from point to cursor position, inserting spaces."
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))
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))))))