Mercurial > emacs
annotate lisp/mouse.el @ 1058:19c6978ab218
*** empty log message ***
author | Richard M. Stallman <rms@gnu.org> |
---|---|
date | Mon, 31 Aug 1992 06:47:03 +0000 |
parents | d9775f33488d |
children | af78c65921c8 |
rev | line source |
---|---|
659
505130d1ddf8
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
584
diff
changeset
|
1 ;;; mouse.el --- window system-independent mouse support. |
791
203c23c9f22c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
758
diff
changeset
|
2 |
840
113281b361ec
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
791
diff
changeset
|
3 ;;; Copyright (C) 1988, 1992 Free Software Foundation, Inc. |
113281b361ec
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
791
diff
changeset
|
4 |
791
203c23c9f22c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
758
diff
changeset
|
5 ;; Maintainer: FSF |
203c23c9f22c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
758
diff
changeset
|
6 ;; Keywords: hardware |
203c23c9f22c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
758
diff
changeset
|
7 |
465 | 8 ;;; This file is part of GNU Emacs. |
66 | 9 |
465 | 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 | |
705 | 12 ;;; the Free Software Foundation; either version 2, or (at your option) |
465 | 13 ;;; any later version. |
66 | 14 |
465 | 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. | |
66 | 19 |
465 | 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. | |
66 | 23 |
24 | |
465 | 25 ;;; Utility functions. |
26 | |
27 (defun mouse-movement-p (event) | |
28 (and (consp event) | |
29 (eq (car event) 'mouse-movement))) | |
30 | |
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)) | |
66 | 35 |
465 | 36 ;;; Indent track-mouse like progn. |
37 (put 'track-mouse 'lisp-indent-function 0) | |
66 | 38 |
465 | 39 |
40 (defun mouse-delete-window (click) | |
41 "Delete the window clicked on. | |
42 This 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. | |
48 This must be bound to a mouse click." | |
49 (interactive "K") | |
50 (select-window (event-window click)) | |
66 | 51 (delete-other-windows)) |
52 | |
465 | 53 (defun mouse-split-window-vertically (click) |
54 "Select Emacs window mouse is on, then split it vertically in half. | |
55 The window is split at the line clicked on. | |
56 This 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))))) | |
66 | 60 |
465 | 61 (defun mouse-set-point (click) |
62 "Move point to the position clicked on with the mouse. | |
63 This must be bound to a mouse click." | |
64 (interactive "K") | |
65 (select-window (event-window click)) | |
1039 | 66 (if (numberp (event-point click)) |
67 (goto-char (event-point click)))) | |
66 | 68 |
465 | 69 (defun mouse-set-mark (click) |
70 "Set mark at the position clicked on with the mouse. | |
71 Display cursor at that position for a second. | |
72 This must be bound to a mouse click." | |
73 (interactive "K") | |
66 | 74 (let ((point-save (point))) |
75 (unwind-protect | |
465 | 76 (progn (mouse-set-point click) |
66 | 77 (push-mark nil t) |
191 | 78 (sit-for 1)) |
66 | 79 (goto-char point-save)))) |
80 | |
465 | 81 (defun mouse-kill (click) |
82 "Kill the region between point and the mouse click. | |
83 The text is saved in the kill ring, as with \\[kill-region]." | |
84 (interactive "K") | |
758 | 85 (let ((click-posn (event-point click))) |
1039 | 86 (if (numberp click-posn) |
87 (kill-region (min (point) click-posn) | |
88 (max (point) click-posn))))) | |
66 | 89 |
705 | 90 (defun mouse-yank-at-click (click arg) |
91 "Insert the last stretch of killed text at the position clicked on. | |
92 Prefix 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) | |
465 | 98 "Copy the region between point and the mouse click in the kill ring. |
99 This does not delete the region; it acts like \\[kill-ring-save]." | |
100 (interactive "K") | |
101 (mouse-set-mark click) | |
705 | 102 (call-interactively 'kill-ring-save)) |
66 | 103 |
1056
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
104 (defun mouse-buffer-menu (event) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
105 "Pop up a menu of buffers for selection with the mouse." |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
106 (interactive "K") |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
107 (let ((menu |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
108 (list "Buffer Menu" |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
109 (cons "Select Buffer" |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
110 (let ((tail (buffer-list)) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
111 head) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
112 (while tail |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
113 (let ((elt (car tail))) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
114 (if (not (string-match "^ " |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
115 (buffer-name elt))) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
116 (setq head (cons |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
117 (cons |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
118 (format |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
119 "%14s %s" |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
120 (buffer-name elt) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
121 (or (buffer-file-name elt) "")) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
122 elt) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
123 head)))) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
124 (setq tail (cdr tail))) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
125 (reverse head)))))) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
126 (switch-to-buffer (or (x-popup-menu event menu) (current-buffer))))) |
66 | 127 |
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 | |
465 | 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)) | |
66 | 264 |
265 | |
303 | 266 ;;;; |
267 ;;;; Here are experimental things being tested. Mouse events | |
268 ;;;; are of the form: | |
269 ;;;; ((x y) window screen-part key-sequence timestamp) | |
66 | 270 ;; |
303 | 271 ;;;; |
272 ;;;; Dynamically track mouse coordinates | |
273 ;;;; | |
66 | 274 ;; |
303 | 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))))) | |
66 | 290 |
291 ;; | |
292 ;; Dynamically put a box around the line indicated by point | |
293 ;; | |
758 | 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)))) | |
66 | 362 |
465 | 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)) | |
66 | 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 | |
465 | 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)) | |
66 | 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 | |
465 | 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))) | |
66 | 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)))))) | |
465 | 483 |
484 | |
485 ;;; Bindings for mouse commands. | |
486 | |
1057
d9775f33488d
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1056
diff
changeset
|
487 ;; This first won't be needed once the drag and down events |
d9775f33488d
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1056
diff
changeset
|
488 ;; are properly implemented. |
d9775f33488d
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1056
diff
changeset
|
489 (global-set-key [mouse-1] 'mouse-set-point) |
d9775f33488d
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1056
diff
changeset
|
490 |
1056
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
491 (global-set-key [down-mouse-1] 'mouse-set-point) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
492 (global-set-key [drag-mouse-1] 'mouse-set-mark) |
705 | 493 (global-set-key [mouse-2] 'mouse-yank-at-click) |
494 (global-set-key [mouse-3] 'mouse-kill-ring-save) | |
1056
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
495 (global-set-key [S-mouse-3] 'mouse-kill) |
705 | 496 |
1056
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
497 (global-set-key [C-mouse-1] 'mouse-buffer-menu) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
498 |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
499 ;; Replaced with dragging mouse-1 |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
500 ;; (global-set-key [S-mouse-1] 'mouse-set-mark) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
501 |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
502 (defvar help-menu-map '(keymap "Help")) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
503 (global-set-key [C-mouse-2] help-menu-map) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
504 |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
505 (defvar help-apropos-map '(keymap "Is there a command that...")) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
506 (defvar help-keys-map '(keymap "Key Commands <==> Functions")) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
507 (defvar help-manual-map '(keymap "Manual and tutorial")) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
508 (defvar help-misc-map '(keymap "Odds and ends")) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
509 (defvar help-modes-map '(keymap "Modes")) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
510 (defvar help-admin-map '(keymap "Administrivia")) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
511 |
1058
19c6978ab218
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1057
diff
changeset
|
512 (define-key help-menu-map [apropos] |
1056
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
513 (cons "Is there a command that..." help-apropos-map)) |
1058
19c6978ab218
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1057
diff
changeset
|
514 (define-key help-menu-map [keys] |
1056
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
515 (cons "Key Commands <==> Functions" help-keys-map)) |
1058
19c6978ab218
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1057
diff
changeset
|
516 (define-key help-menu-map [manuals] |
1056
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
517 (cons "Manual and tutorial" help-manual-map)) |
1058
19c6978ab218
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1057
diff
changeset
|
518 (define-key help-menu-map [misc] |
1056
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
519 (cons "Odds and ends" help-misc-map)) |
1058
19c6978ab218
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1057
diff
changeset
|
520 (define-key help-menu-map [modes] |
1056
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
521 (cons "Modes" help-modes-map)) |
1058
19c6978ab218
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1057
diff
changeset
|
522 (define-key help-menu-map [admin] |
1056
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
523 (cons "Administrivia" help-admin-map)) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
524 |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
525 (define-key help-apropos-map "c" '("Command Apropos" . command-apropos)) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
526 (define-key help-apropos-map "a" '("Apropos" . apropos)) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
527 |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
528 (define-key help-keys-map "b" |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
529 '("List all keystroke commands" . describe-bindings)) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
530 (define-key help-keys-map "c" |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
531 '("Describe key briefly" . describe-key-briefly)) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
532 (define-key help-keys-map "k" |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
533 '("Describe key verbose" . describe-key)) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
534 (define-key help-keys-map "f" |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
535 '("Describe Lisp function" . describe-function)) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
536 (define-key help-keys-map "w" |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
537 '("Where is this command" . where-is)) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
538 |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
539 (define-key help-manual-map "i" '("Info system" . info)) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
540 (define-key help-manual-map "t" |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
541 '("Invoke Emacs tutorial" . help-with-tutorial)) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
542 |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
543 (define-key help-misc-map "l" '("Last 100 Keystrokes" . view-lossage)) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
544 (define-key help-misc-map "s" '("Describe syntax table" . describe-syntax)) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
545 |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
546 (define-key help-modes-map "m" |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
547 '("Describe current major mode" . describe-mode)) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
548 (define-key help-modes-map "b" |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
549 '("List all keystroke commands" . describe-bindings)) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
550 |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
551 (define-key help-admin-map "n" |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
552 '("view Emacs news" . view-emacs-news)) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
553 (define-key help-admin-map "l" |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
554 '("View the GNU Emacs license" . describe-copying)) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
555 (define-key help-admin-map "d" |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
556 '("Describe distribution" . describe-distribution)) |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
557 (define-key help-admin-map "w" |
a7fc54083464
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1039
diff
changeset
|
558 '("Describe (non)warranty" . describe-no-warranty)) |
584 | 559 |
560 (provide 'mouse) | |
561 | |
659
505130d1ddf8
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
584
diff
changeset
|
562 ;;; mouse.el ends here |