(Fdo_auto_save): Always call record_auto_save.
[bpt/emacs.git] / lisp / mouse.el
CommitLineData
6594deb0 1;;; mouse.el --- window system-independent mouse support.
84176303 2
eea8d4ef
ER
3;;; Copyright (C) 1988, 1992 Free Software Foundation, Inc.
4
84176303 5;; Maintainer: FSF
84176303
ER
6;; Keywords: hardware
7
cc0a8174 8;;; This file is part of GNU Emacs.
72ea54a4 9
cc0a8174
JB
10;;; GNU Emacs is free software; you can redistribute it and/or modify
11;;; it under the terms of the GNU General Public License as published by
87ef29fd 12;;; the Free Software Foundation; either version 2, or (at your option)
cc0a8174 13;;; any later version.
72ea54a4 14
cc0a8174
JB
15;;; GNU Emacs is distributed in the hope that it will be useful,
16;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;;; GNU General Public License for more details.
72ea54a4 19
cc0a8174
JB
20;;; You should have received a copy of the GNU General Public License
21;;; along with GNU Emacs; see the file COPYING. If not, write to
22;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
72ea54a4 23
72ea54a4 24\f
cc0a8174 25;;; Utility functions.
72ea54a4 26
cc0a8174
JB
27(defun mouse-movement-p (event)
28 (and (consp event)
29 (eq (car event) 'mouse-movement)))
72ea54a4 30
cc0a8174
JB
31(defun event-window (event) (nth 1 event))
32(defun event-point (event) (nth 2 event))
33(defun mouse-coords (event) (nth 3 event))
34(defun mouse-timestamp (event) (nth 4 event))
72ea54a4 35
cc0a8174
JB
36;;; Indent track-mouse like progn.
37(put 'track-mouse 'lisp-indent-function 0)
72ea54a4 38
cc0a8174
JB
39\f
40(defun mouse-delete-window (click)
41 "Delete the window clicked on.
42This must be bound to a mouse click."
43 (interactive "K")
44 (delete-window (event-window click)))
45
46(defun mouse-delete-other-windows (click)
47 "Select Emacs window clicked on, then kill all other Emacs windows.
48This must be bound to a mouse click."
49 (interactive "K")
50 (select-window (event-window click))
51 (delete-other-windows))
72ea54a4 52
cc0a8174
JB
53(defun mouse-split-window-vertically (click)
54 "Select Emacs window mouse is on, then split it vertically in half.
55The window is split at the line clicked on.
56This command must be bound to a mouse click."
57 (interactive "K")
58 (select-window (event-window click))
59 (split-window-vertically (1+ (cdr (mouse-coords click)))))
60
61(defun mouse-set-point (click)
62 "Move point to the position clicked on with the mouse.
63This must be bound to a mouse click."
64 (interactive "K")
65 (select-window (event-window click))
bd307392
JB
66 (if (numberp (event-point click))
67 (goto-char (event-point click))))
cc0a8174
JB
68
69(defun mouse-set-mark (click)
70 "Set mark at the position clicked on with the mouse.
71Display cursor at that position for a second.
72This must be bound to a mouse click."
73 (interactive "K")
72ea54a4
RS
74 (let ((point-save (point)))
75 (unwind-protect
cc0a8174 76 (progn (mouse-set-point click)
72ea54a4 77 (push-mark nil t)
fe79ff61 78 (sit-for 1))
72ea54a4
RS
79 (goto-char point-save))))
80
cc0a8174
JB
81(defun mouse-kill (click)
82 "Kill the region between point and the mouse click.
83The text is saved in the kill ring, as with \\[kill-region]."
84 (interactive "K")
7047ec77 85 (let ((click-posn (event-point click)))
bd307392
JB
86 (if (numberp click-posn)
87 (kill-region (min (point) click-posn)
88 (max (point) click-posn)))))
72ea54a4 89
87ef29fd
JB
90(defun mouse-yank-at-click (click arg)
91 "Insert the last stretch of killed text at the position clicked on.
92Prefix arguments are interpreted as with \\[yank]."
93 (interactive "K\nP")
94 (mouse-set-point click)
95 (yank arg))
96
97(defun mouse-kill-ring-save (click)
cc0a8174
JB
98 "Copy the region between point and the mouse click in the kill ring.
99This does not delete the region; it acts like \\[kill-ring-save]."
100 (interactive "K")
101 (mouse-set-mark click)
87ef29fd 102 (call-interactively 'kill-ring-save))
72ea54a4 103
8b34e79d
RS
104(defun mouse-buffer-menu (event)
105 "Pop up a menu of buffers for selection with the mouse."
106 (interactive "K")
107 (let ((menu
108 (list "Buffer Menu"
109 (cons "Select Buffer"
110 (let ((tail (buffer-list))
111 head)
112 (while tail
113 (let ((elt (car tail)))
114 (if (not (string-match "^ "
115 (buffer-name elt)))
116 (setq head (cons
117 (cons
118 (format
119 "%14s %s"
120 (buffer-name elt)
121 (or (buffer-file-name elt) ""))
122 elt)
123 head))))
124 (setq tail (cdr tail)))
125 (reverse head))))))
126 (switch-to-buffer (or (x-popup-menu event menu) (current-buffer)))))
72ea54a4
RS
127\f
128;; Commands for the scroll bar.
129
130(defun mouse-scroll-down (nlines)
131 (interactive "@p")
132 (scroll-down nlines))
133
134(defun mouse-scroll-up (nlines)
135 (interactive "@p")
136 (scroll-up nlines))
137
138(defun mouse-scroll-down-full ()
139 (interactive "@")
140 (scroll-down nil))
141
142(defun mouse-scroll-up-full ()
143 (interactive "@")
144 (scroll-up nil))
145
146(defun mouse-scroll-move-cursor (nlines)
147 (interactive "@p")
148 (move-to-window-line nlines))
149
150(defun mouse-scroll-absolute (event)
151 (interactive "@e")
152 (let* ((pos (car event))
153 (position (car pos))
154 (length (car (cdr pos))))
155 (if (<= length 0) (setq length 1))
156 (let* ((scale-factor (max 1 (/ length (/ 8000000 (buffer-size)))))
157 (newpos (* (/ (* (/ (buffer-size) scale-factor)
158 position)
159 length)
160 scale-factor)))
161 (goto-char newpos)
162 (recenter '(4)))))
163
164(defun mouse-scroll-left (ncolumns)
165 (interactive "@p")
166 (scroll-left ncolumns))
167
168(defun mouse-scroll-right (ncolumns)
169 (interactive "@p")
170 (scroll-right ncolumns))
171
172(defun mouse-scroll-left-full ()
173 (interactive "@")
174 (scroll-left nil))
175
176(defun mouse-scroll-right-full ()
177 (interactive "@")
178 (scroll-right nil))
179
180(defun mouse-scroll-move-cursor-horizontally (ncolumns)
181 (interactive "@p")
182 (move-to-column ncolumns))
183
184(defun mouse-scroll-absolute-horizontally (event)
185 (interactive "@e")
186 (let* ((pos (car event))
187 (position (car pos))
188 (length (car (cdr pos))))
189 (set-window-hscroll (selected-window) 33)))
190
191;; Set up these commands, including the prefix keys for the scroll bar.
192
cc0a8174
JB
193;;; (fset 'mouse-vertical-scroll-bar-prefix (make-sparse-keymap))
194;;; (define-key global-mouse-map mouse-vertical-scroll-bar-prefix
195;;; 'mouse-vertical-scroll-bar-prefix)
196;;;
197;;; (defun mouse-scroll-motion (event)
198;;; (interactive "e")
199;;; (let ((pos (car (car event)))
200;;; (length (car (cdr (car event)))))
201;;; (message "[%d %d]" pos length)))
202;;;
203;;; (let ((map (function mouse-vertical-scroll-bar-prefix)))
204;;; (define-key map mouse-button-right 'mouse-scroll-down)
205;;; (define-key map mouse-button-left 'mouse-scroll-up)
206;;; (define-key map mouse-button-middle 'mouse-scroll-absolute)
207;;; (define-key map mouse-motion 'x-horizontal-line))
208;;;
209;;; ;(fset 'mouse-vertical-slider-prefix (make-sparse-keymap))
210;;; ;(define-key global-mouse-map mouse-vertical-slider-prefix
211;;; ; 'mouse-vertical-slider-prefix)
212;;;
213;;; ;(let ((map (function mouse-vertical-slider-prefix)))
214;;; ; (define-key map mouse-button-right 'mouse-scroll-move-cursor)
215;;; ; (define-key map mouse-button-left 'mouse-scroll-move-cursor)
216;;; ; (define-key map mouse-button-middle 'mouse-scroll-move-cursor))
217;;;
218;;; (fset 'mouse-vertical-thumbup-prefix (make-sparse-keymap))
219;;; (define-key global-mouse-map mouse-vertical-thumbup-prefix
220;;; 'mouse-vertical-thumbup-prefix)
221;;;
222;;; (let ((map (function mouse-vertical-thumbup-prefix)))
223;;; (define-key map mouse-button-right 'mouse-scroll-down-full)
224;;; (define-key map mouse-button-left 'mouse-scroll-down-full)
225;;; (define-key map mouse-button-middle 'mouse-scroll-down-full))
226;;;
227;;; (fset 'mouse-vertical-thumbdown-prefix (make-sparse-keymap))
228;;; (define-key global-mouse-map mouse-vertical-thumbdown-prefix
229;;; 'mouse-vertical-thumbdown-prefix)
230;;;
231;;; (let ((map (function mouse-vertical-thumbdown-prefix)))
232;;; (define-key map mouse-button-right 'mouse-scroll-up-full)
233;;; (define-key map mouse-button-left 'mouse-scroll-up-full)
234;;; (define-key map mouse-button-middle 'mouse-scroll-up-full))
235;;;
236;;; ;; Horizontal bar
237;;;
238;;; (fset 'mouse-horizontal-scroll-bar-prefix (make-sparse-keymap))
239;;; (define-key global-mouse-map mouse-horizontal-scroll-bar-prefix
240;;; 'mouse-horizontal-scroll-bar-prefix)
241;;;
242;;; (let ((map (function mouse-horizontal-scroll-bar-prefix)))
243;;; (define-key map mouse-button-right 'mouse-scroll-right)
244;;; (define-key map mouse-button-left 'mouse-scroll-left)
245;;; (define-key map mouse-button-middle 'mouse-scroll-absolute-horizontally))
246;;;
247;;; (fset 'mouse-horizontal-thumbleft-prefix (make-sparse-keymap))
248;;; (define-key global-mouse-map mouse-horizontal-thumbleft-prefix
249;;; 'mouse-horizontal-thumbleft-prefix)
250;;;
251;;; (let ((map (function mouse-horizontal-thumbleft-prefix)))
252;;; (define-key map mouse-button-right 'mouse-scroll-left-full)
253;;; (define-key map mouse-button-left 'mouse-scroll-left-full)
254;;; (define-key map mouse-button-middle 'mouse-scroll-left-full))
255;;;
256;;; (fset 'mouse-horizontal-thumbright-prefix (make-sparse-keymap))
257;;; (define-key global-mouse-map mouse-horizontal-thumbright-prefix
258;;; 'mouse-horizontal-thumbright-prefix)
259;;;
260;;; (let ((map (function mouse-horizontal-thumbright-prefix)))
261;;; (define-key map mouse-button-right 'mouse-scroll-right-full)
262;;; (define-key map mouse-button-left 'mouse-scroll-right-full)
263;;; (define-key map mouse-button-middle 'mouse-scroll-right-full))
72ea54a4
RS
264
265
84545e78
JB
266;;;;
267;;;; Here are experimental things being tested. Mouse events
268;;;; are of the form:
269;;;; ((x y) window screen-part key-sequence timestamp)
72ea54a4 270;;
84545e78
JB
271;;;;
272;;;; Dynamically track mouse coordinates
273;;;;
72ea54a4 274;;
84545e78
JB
275;;(defun track-mouse (event)
276;; "Track the coordinates, absolute and relative, of the mouse."
277;; (interactive "@e")
278;; (while mouse-grabbed
279;; (let* ((pos (read-mouse-position (selected-screen)))
280;; (abs-x (car pos))
281;; (abs-y (cdr pos))
282;; (relative-coordinate (coordinates-in-window-p
283;; (list (car pos) (cdr pos))
284;; (selected-window))))
285;; (if (consp relative-coordinate)
286;; (message "mouse: [%d %d], (%d %d)" abs-x abs-y
287;; (car relative-coordinate)
288;; (car (cdr relative-coordinate)))
289;; (message "mouse: [%d %d]" abs-x abs-y)))))
72ea54a4
RS
290
291;;
292;; Dynamically put a box around the line indicated by point
293;;
7047ec77
JB
294;;
295;;(require 'backquote)
296;;
297;;(defun mouse-select-buffer-line (event)
298;; (interactive "@e")
299;; (let ((relative-coordinate
300;; (coordinates-in-window-p (car event) (selected-window)))
301;; (abs-y (car (cdr (car event)))))
302;; (if (consp relative-coordinate)
303;; (progn
304;; (save-excursion
305;; (move-to-window-line (car (cdr relative-coordinate)))
306;; (x-draw-rectangle
307;; (selected-screen)
308;; abs-y 0
309;; (save-excursion
310;; (move-to-window-line (car (cdr relative-coordinate)))
311;; (end-of-line)
312;; (push-mark nil t)
313;; (beginning-of-line)
314;; (- (region-end) (region-beginning))) 1))
315;; (sit-for 1)
316;; (x-erase-rectangle (selected-screen))))))
317;;
318;;(defvar last-line-drawn nil)
319;;(defvar begin-delim "[^ \t]")
320;;(defvar end-delim "[^ \t]")
321;;
322;;(defun mouse-boxing (event)
323;; (interactive "@e")
324;; (save-excursion
325;; (let ((screen (selected-screen)))
326;; (while (= (x-mouse-events) 0)
327;; (let* ((pos (read-mouse-position screen))
328;; (abs-x (car pos))
329;; (abs-y (cdr pos))
330;; (relative-coordinate
331;; (coordinates-in-window-p (` ((, abs-x) (, abs-y)))
332;; (selected-window)))
333;; (begin-reg nil)
334;; (end-reg nil)
335;; (end-column nil)
336;; (begin-column nil))
337;; (if (and (consp relative-coordinate)
338;; (or (not last-line-drawn)
339;; (not (= last-line-drawn abs-y))))
340;; (progn
341;; (move-to-window-line (car (cdr relative-coordinate)))
342;; (if (= (following-char) 10)
343;; ()
344;; (progn
345;; (setq begin-reg (1- (re-search-forward end-delim)))
346;; (setq begin-column (1- (current-column)))
347;; (end-of-line)
348;; (setq end-reg (1+ (re-search-backward begin-delim)))
349;; (setq end-column (1+ (current-column)))
350;; (message "%s" (buffer-substring begin-reg end-reg))
351;; (x-draw-rectangle screen
352;; (setq last-line-drawn abs-y)
353;; begin-column
354;; (- end-column begin-column) 1))))))))))
355;;
356;;(defun mouse-erase-box ()
357;; (interactive)
358;; (if last-line-drawn
359;; (progn
360;; (x-erase-rectangle (selected-screen))
361;; (setq last-line-drawn nil))))
72ea54a4 362
cc0a8174
JB
363;;; (defun test-x-rectangle ()
364;;; (use-local-mouse-map (setq rectangle-test-map (make-sparse-keymap)))
365;;; (define-key rectangle-test-map mouse-motion-button-left 'mouse-boxing)
366;;; (define-key rectangle-test-map mouse-button-left-up 'mouse-erase-box))
72ea54a4
RS
367
368;;
369;; Here is how to do double clicking in lisp. About to change.
370;;
371
372(defvar double-start nil)
373(defconst double-click-interval 300
374 "Max ticks between clicks")
375
376(defun double-down (event)
377 (interactive "@e")
378 (if double-start
379 (let ((interval (- (nth 4 event) double-start)))
380 (if (< interval double-click-interval)
381 (progn
382 (backward-up-list 1)
383 ;; (message "Interval %d" interval)
384 (sleep-for 1)))
385 (setq double-start nil))
386 (setq double-start (nth 4 event))))
387
388(defun double-up (event)
389 (interactive "@e")
390 (and double-start
391 (> (- (nth 4 event ) double-start) double-click-interval)
392 (setq double-start nil)))
393
cc0a8174
JB
394;;; (defun x-test-doubleclick ()
395;;; (use-local-mouse-map (setq doubleclick-test-map (make-sparse-keymap)))
396;;; (define-key doubleclick-test-map mouse-button-left 'double-down)
397;;; (define-key doubleclick-test-map mouse-button-left-up 'double-up))
72ea54a4
RS
398
399;;
400;; This scrolls while button is depressed. Use preferable in scrollbar.
401;;
402
403(defvar scrolled-lines 0)
404(defconst scroll-speed 1)
405
406(defun incr-scroll-down (event)
407 (interactive "@e")
408 (setq scrolled-lines 0)
409 (incremental-scroll scroll-speed))
410
411(defun incr-scroll-up (event)
412 (interactive "@e")
413 (setq scrolled-lines 0)
414 (incremental-scroll (- scroll-speed)))
415
416(defun incremental-scroll (n)
417 (while (= (x-mouse-events) 0)
418 (setq scrolled-lines (1+ (* scroll-speed scrolled-lines)))
419 (scroll-down n)
420 (sit-for 300 t)))
421
422(defun incr-scroll-stop (event)
423 (interactive "@e")
424 (message "Scrolled %d lines" scrolled-lines)
425 (setq scrolled-lines 0)
426 (sleep-for 1))
427
cc0a8174
JB
428;;; (defun x-testing-scroll ()
429;;; (let ((scrolling-map (function mouse-vertical-scroll-bar-prefix)))
430;;; (define-key scrolling-map mouse-button-left 'incr-scroll-down)
431;;; (define-key scrolling-map mouse-button-right 'incr-scroll-up)
432;;; (define-key scrolling-map mouse-button-left-up 'incr-scroll-stop)
433;;; (define-key scrolling-map mouse-button-right-up 'incr-scroll-stop)))
72ea54a4
RS
434
435;;
436;; Some playthings suitable for picture mode? They need work.
437;;
438
439(defun mouse-kill-rectangle (event)
440 "Kill the rectangle between point and the mouse cursor."
441 (interactive "@e")
442 (let ((point-save (point)))
443 (save-excursion
444 (mouse-set-point event)
445 (push-mark nil t)
446 (if (> point-save (point))
447 (kill-rectangle (point) point-save)
448 (kill-rectangle point-save (point))))))
449
450(defun mouse-open-rectangle (event)
451 "Kill the rectangle between point and the mouse cursor."
452 (interactive "@e")
453 (let ((point-save (point)))
454 (save-excursion
455 (mouse-set-point event)
456 (push-mark nil t)
457 (if (> point-save (point))
458 (open-rectangle (point) point-save)
459 (open-rectangle point-save (point))))))
460
461;; Must be a better way to do this.
462
463(defun mouse-multiple-insert (n char)
464 (while (> n 0)
465 (insert char)
466 (setq n (1- n))))
467
468;; What this could do is not finalize until button was released.
469
470(defun mouse-move-text (event)
471 "Move text from point to cursor position, inserting spaces."
472 (interactive "@e")
473 (let* ((relative-coordinate
474 (coordinates-in-window-p (car event) (selected-window))))
475 (if (consp relative-coordinate)
476 (cond ((> (current-column) (car relative-coordinate))
477 (delete-char
478 (- (car relative-coordinate) (current-column))))
479 ((< (current-column) (car relative-coordinate))
480 (mouse-multiple-insert
481 (- (car relative-coordinate) (current-column)) " "))
482 ((= (current-column) (car relative-coordinate)) (ding))))))
cc0a8174
JB
483
484\f
485;;; Bindings for mouse commands.
486
6e3ccc70
RS
487;; This first won't be needed once the drag and down events
488;; are properly implemented.
489(global-set-key [mouse-1] 'mouse-set-point)
490
8b34e79d
RS
491(global-set-key [down-mouse-1] 'mouse-set-point)
492(global-set-key [drag-mouse-1] 'mouse-set-mark)
87ef29fd
JB
493(global-set-key [mouse-2] 'mouse-yank-at-click)
494(global-set-key [mouse-3] 'mouse-kill-ring-save)
8b34e79d 495(global-set-key [S-mouse-3] 'mouse-kill)
87ef29fd 496
8b34e79d
RS
497(global-set-key [C-mouse-1] 'mouse-buffer-menu)
498
499;; Replaced with dragging mouse-1
500;; (global-set-key [S-mouse-1] 'mouse-set-mark)
501\f
502(defvar help-menu-map '(keymap "Help"))
503(global-set-key [C-mouse-2] help-menu-map)
504
505(defvar help-apropos-map '(keymap "Is there a command that..."))
506(defvar help-keys-map '(keymap "Key Commands <==> Functions"))
507(defvar help-manual-map '(keymap "Manual and tutorial"))
508(defvar help-misc-map '(keymap "Odds and ends"))
509(defvar help-modes-map '(keymap "Modes"))
510(defvar help-admin-map '(keymap "Administrivia"))
511
e7691e9c 512(define-key help-menu-map [apropos]
8b34e79d 513 (cons "Is there a command that..." help-apropos-map))
e7691e9c 514(define-key help-menu-map [keys]
8b34e79d 515 (cons "Key Commands <==> Functions" help-keys-map))
e7691e9c 516(define-key help-menu-map [manuals]
8b34e79d 517 (cons "Manual and tutorial" help-manual-map))
e7691e9c 518(define-key help-menu-map [misc]
8b34e79d 519 (cons "Odds and ends" help-misc-map))
e7691e9c 520(define-key help-menu-map [modes]
8b34e79d 521 (cons "Modes" help-modes-map))
e7691e9c 522(define-key help-menu-map [admin]
8b34e79d
RS
523 (cons "Administrivia" help-admin-map))
524
525(define-key help-apropos-map "c" '("Command Apropos" . command-apropos))
526(define-key help-apropos-map "a" '("Apropos" . apropos))
527
528(define-key help-keys-map "b"
529 '("List all keystroke commands" . describe-bindings))
530(define-key help-keys-map "c"
531 '("Describe key briefly" . describe-key-briefly))
532(define-key help-keys-map "k"
533 '("Describe key verbose" . describe-key))
534(define-key help-keys-map "f"
535 '("Describe Lisp function" . describe-function))
536(define-key help-keys-map "w"
537 '("Where is this command" . where-is))
538
539(define-key help-manual-map "i" '("Info system" . info))
540(define-key help-manual-map "t"
541 '("Invoke Emacs tutorial" . help-with-tutorial))
542
543(define-key help-misc-map "l" '("Last 100 Keystrokes" . view-lossage))
544(define-key help-misc-map "s" '("Describe syntax table" . describe-syntax))
545
546(define-key help-modes-map "m"
547 '("Describe current major mode" . describe-mode))
548(define-key help-modes-map "b"
549 '("List all keystroke commands" . describe-bindings))
550
551(define-key help-admin-map "n"
552 '("view Emacs news" . view-emacs-news))
553(define-key help-admin-map "l"
554 '("View the GNU Emacs license" . describe-copying))
555(define-key help-admin-map "d"
556 '("Describe distribution" . describe-distribution))
557(define-key help-admin-map "w"
558 '("Describe (non)warranty" . describe-no-warranty))
49116ac0
JB
559
560(provide 'mouse)
561
6594deb0 562;;; mouse.el ends here