mouse.el 77 KB
Newer Older
Richard M. Stallman's avatar
Richard M. Stallman committed
1
;;; mouse.el --- window system-independent mouse support
Eric S. Raymond's avatar
Eric S. Raymond committed
2

Dave Love's avatar
Dave Love committed
3
;; Copyright (C) 1993, 1994, 1995, 1999 Free Software Foundation, Inc.
Eric S. Raymond's avatar
Eric S. Raymond committed
4

Eric S. Raymond's avatar
Eric S. Raymond committed
5 6 7
;; Maintainer: FSF
;; Keywords: hardware

Richard M. Stallman's avatar
Richard M. Stallman committed
8
;; This file is part of GNU Emacs.
Richard M. Stallman's avatar
Richard M. Stallman committed
9

Richard M. Stallman's avatar
Richard M. Stallman committed
10 11 12 13
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
Richard M. Stallman's avatar
Richard M. Stallman committed
14

Richard M. Stallman's avatar
Richard M. Stallman committed
15 16 17 18
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
Richard M. Stallman's avatar
Richard M. Stallman committed
19

Richard M. Stallman's avatar
Richard M. Stallman committed
20
;; You should have received a copy of the GNU General Public License
21 22 23
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
Richard M. Stallman's avatar
Richard M. Stallman committed
24

25 26 27 28 29 30 31 32
;;; Commentary:

;; This package provides various useful commands (including help
;; system access) through the mouse.  All this code assumes that mouse
;; interpretation has been abstracted into Emacs input events.
;;
;; The code is rather X-dependent.

33 34
;;; Code:

Jim Blandy's avatar
Jim Blandy committed
35
;;; Utility functions.
Richard M. Stallman's avatar
Richard M. Stallman committed
36

Jim Blandy's avatar
Jim Blandy committed
37 38
;;; Indent track-mouse like progn.
(put 'track-mouse 'lisp-indent-function 0)
Richard M. Stallman's avatar
Richard M. Stallman committed
39

Richard M. Stallman's avatar
Richard M. Stallman committed
40 41 42 43
(defcustom mouse-yank-at-point nil
  "*If non-nil, mouse yank commands yank at point instead of at click."
  :type 'boolean
  :group 'mouse)
Jim Blandy's avatar
Jim Blandy committed
44

45 46
;; Provide a mode-specific menu on a mouse button.

47
(defun mouse-major-mode-menu (event prefix)
48 49
  "Pop up a mode-specific menu of mouse commands.
Default to the Edit menu if the major mode doesn't define a menu."
50 51
  ;; Switch to the window clicked on, because otherwise
  ;; the mode's commands may not make sense.
52
  (interactive "@e\nP")
53 54
  ;; Let the mode update its menus first.
  (run-hooks 'activate-menubar-hook)
55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72
  (let* (;; This is where mouse-major-mode-menu-prefix
	 ;; returns the prefix we should use (after menu-bar).
	 ;; It is either nil or (SOME-SYMBOL).
	 (mouse-major-mode-menu-prefix nil)
	 ;; Keymap from which to inherit; may be null.
	 (ancestor (mouse-major-mode-menu-1
		    (and (current-local-map)
			 (lookup-key (current-local-map) [menu-bar]))))
	 ;; Make a keymap in which our last command leads to a menu or
	 ;; default to the edit menu.
	 (newmap (if ancestor
		     (make-sparse-keymap (concat mode-name " Mode"))
		   menu-bar-edit-menu))
	 result)
    (if ancestor
	;; Make our menu inherit from the desired keymap which we want
	;; to display as the menu now.
	(set-keymap-parent newmap ancestor))
73 74 75 76 77 78
    (setq result (x-popup-menu t (list newmap)))
    (if result
	(let ((command (key-binding
			(apply 'vector (append '(menu-bar)
					       mouse-major-mode-menu-prefix
					       result)))))
79 80
	  ;; Clear out echoing, which perhaps shows a prefix arg.
	  (message "")
81
	  (if command
82 83 84
	      (progn
		(setq prefix-arg prefix)
		(command-execute command)))))))
85 86

;; Compute and cache the equivalent keys in MENU and all its submenus.
87 88 89 90 91 92 93 94 95 96 97 98 99
;;;(defun mouse-major-mode-menu-compute-equiv-keys (menu)
;;;  (and (eq (car menu) 'keymap)
;;;       (x-popup-menu nil menu))
;;;  (while menu
;;;    (and (consp (car menu))
;;;	 (consp (cdr (car menu)))
;;;	 (let ((tail (cdr (car menu))))
;;;	   (while (and (consp tail)
;;;		       (not (eq (car tail) 'keymap)))
;;;	     (setq tail (cdr tail)))
;;;	   (if (consp tail)
;;;	       (mouse-major-mode-menu-compute-equiv-keys tail))))
;;;    (setq menu (cdr menu))))
100 101 102 103 104 105 106 107 108 109 110 111 112

;; Given a mode's menu bar keymap,
;; if it defines exactly one menu bar menu,
;; return just that menu.
;; Otherwise return a menu for all of them.
(defun mouse-major-mode-menu-1 (menubar)
  (if menubar
      (let ((tail menubar)
	    submap)
	(while tail
	  (if (consp (car tail))
	      (if submap
		  (setq submap t)
113
		(setq submap (car tail))))
114
	  (setq tail (cdr tail)))
115
	(if (eq submap t)
116
	    menubar
117 118
	  (setq mouse-major-mode-menu-prefix (list (car submap)))
	  (cdr (cdr submap))))))
119

120 121
;; Commands that operate on windows.

122 123 124 125
(defun mouse-minibuffer-check (event)
  (let ((w (posn-window (event-start event))))
    (and (window-minibuffer-p w)
	 (not (minibuffer-window-active-p w))
126 127 128
	 (error "Minibuffer window is not active")))
  ;; Give temporary modes such as isearch a chance to turn off.
  (run-hooks 'mouse-leave-buffer-hook))
129

Jim Blandy's avatar
Jim Blandy committed
130
(defun mouse-delete-window (click)
131
  "Delete the window you click on.
132 133
If the frame has just one window, bury the current buffer instead.
This command must be bound to a mouse click."
Jim Blandy's avatar
Jim Blandy committed
134
  (interactive "e")
135 136 137 138
  (if (one-window-p t)
      (bury-buffer)
    (mouse-minibuffer-check click)
    (delete-window (posn-window (event-start click)))))
Jim Blandy's avatar
Jim Blandy committed
139

140 141 142
(defun mouse-select-window (click)
  "Select the window clicked on; don't move point."
  (interactive "e")
143
  (mouse-minibuffer-check click)
144 145 146 147 148 149
  (let ((oframe (selected-frame))
	(frame (window-frame (posn-window (event-start click)))))
    (select-window (posn-window (event-start click)))
    (raise-frame frame)
    (select-frame frame)
    (or (eq frame oframe)
150
	(set-mouse-position (selected-frame) (1- (frame-width)) 0))))
151

152 153 154
(defun mouse-tear-off-window (click)
  "Delete the window clicked on, and create a new frame displaying its buffer."
  (interactive "e")
155
  (mouse-minibuffer-check click)
156 157
  (let* ((window (posn-window (event-start click)))
	 (buf (window-buffer window))
158
	 (frame (make-frame)))
159 160 161 162
    (select-frame frame)
    (switch-to-buffer buf)
    (delete-window window)))

163
(defun mouse-delete-other-windows ()
164
  "Delete all window except the one you click on."
165
  (interactive "@")
Jim Blandy's avatar
Jim Blandy committed
166
  (delete-other-windows))
Richard M. Stallman's avatar
Richard M. Stallman committed
167

Jim Blandy's avatar
Jim Blandy committed
168 169 170 171
(defun mouse-split-window-vertically (click)
  "Select Emacs window mouse is on, then split it vertically in half.
The window is split at the line clicked on.
This command must be bound to a mouse click."
172
  (interactive "@e")
173
  (mouse-minibuffer-check click)
174 175
  (let ((start (event-start click)))
    (select-window (posn-window start))
176
    (let ((new-height (1+ (cdr (posn-col-row (event-end click)))))
177 178 179
	  (first-line window-min-height)
	  (last-line (- (window-height) window-min-height)))
      (if (< last-line first-line)
180
	  (error "Window too short to split")
181 182
	(split-window-vertically
	 (min (max new-height first-line) last-line))))))
Jim Blandy's avatar
Jim Blandy committed
183

184 185 186 187 188
(defun mouse-split-window-horizontally (click)
  "Select Emacs window mouse is on, then split it horizontally in half.
The window is split at the column clicked on.
This command must be bound to a mouse click."
  (interactive "@e")
189
  (mouse-minibuffer-check click)
190 191 192 193 194 195
  (let ((start (event-start click)))
    (select-window (posn-window start))
    (let ((new-width (1+ (car (posn-col-row (event-end click)))))
	  (first-col window-min-width)
	  (last-col (- (window-width) window-min-width)))
      (if (< last-col first-col)
196
	  (error "Window too narrow to split")
197 198
	(split-window-horizontally
	 (min (max new-width first-col) last-col))))))
199

200 201 202 203
(defun mouse-drag-mode-line-1 (start-event mode-line-p)
  "Change the height of a window by dragging on the mode or header line.
START-EVENT is the starting mouse-event of the drag action.
MODE-LINE-P non-nil means a mode line is dragged."
204 205
  ;; Give temporary modes such as isearch a chance to turn off.
  (run-hooks 'mouse-leave-buffer-hook)
206 207 208 209 210 211 212 213 214
  (let ((done nil)
	(echo-keystrokes 0)
	(start-event-frame (window-frame (car (car (cdr start-event)))))
	(start-event-window (car (car (cdr start-event))))
	(start-nwindows (count-windows t))
	(old-selected-window (selected-window))
	should-enlarge-minibuffer
	event mouse minibuffer y top bot edges wconfig params growth)
    (setq params (frame-parameters))
215
    (setq minibuffer (cdr (assq 'minibuffer params)))
216 217 218 219 220 221 222 223 224 225
    (track-mouse
      (progn
	;; enlarge-window only works on the selected window, so
	;; we must select the window where the start event originated.
	;; unwind-protect will restore the old selected window later.
	(select-window start-event-window)
	;; if this is the bottommost ordinary window, then to
	;; move its modeline the minibuffer must be enlarged.
	(setq should-enlarge-minibuffer
	      (and minibuffer
226
		   mode-line-p
227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264
		   (not (one-window-p t))
		   (= (nth 1 (window-edges minibuffer))
		      (nth 3 (window-edges)))))
	;; loop reading events and sampling the position of
	;; the mouse.
	(while (not done)
	  (setq event (read-event)
		mouse (mouse-position))
	  ;; do nothing if
	  ;;   - there is a switch-frame event.
	  ;;   - the mouse isn't in the frame that we started in
	  ;;   - the mouse isn't in any Emacs frame
	  ;; drag if
	  ;;   - there is a mouse-movement event
	  ;;   - there is a scroll-bar-movement event
	  ;;     (same as mouse movement for our purposes)
	  ;; quit if
	  ;;   - there is a keyboard event or some other unknown event
	  ;;     unknown event.
	  (cond ((integerp event)
		 (setq done t))
		((eq (car event) 'switch-frame)
		 nil)
		((not (memq (car event)
			    '(mouse-movement scroll-bar-movement)))
		 (if (consp event)
		     (setq unread-command-events
			   (cons event unread-command-events)))
		 (setq done t))
		((not (eq (car mouse) start-event-frame))
		 nil)
		((null (car (cdr mouse)))
		 nil)
		(t
		 (setq y (cdr (cdr mouse))
		       edges (window-edges)
		       top (nth 1 edges)
		       bot (nth 3 edges))
265
		 
266
		 ;; compute size change needed
267 268 269 270 271 272 273 274 275 276 277 278
		 (cond (mode-line-p
			;; Scale back a move that would make the
			;; window too short.
			(when (< (- y top -1) window-min-height)
			  (setq y (+ top window-min-height -1)))
			(setq growth (- y bot -1)))
		       (t
			(when (< (- bot y -1) window-min-height)
			  (setq y (- bot window-min-height -1)))
			(setq growth (- top y -1))))
		 (setq wconfig (current-window-configuration))
		 
279 280 281 282 283
		 ;; Check for an error case.
		 (if (and (/= growth 0)
			  (not minibuffer)
			  (one-window-p t))
		     (error "Attempt to resize sole window"))
284
		 
285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302
		 ;; grow/shrink minibuffer?
		 (if should-enlarge-minibuffer
		     (progn
		       ;; yes.  briefly select minibuffer so
		       ;; enlarge-window will affect the
		       ;; correct window.
		       (select-window minibuffer)
		       ;; scale back shrinkage if it would
		       ;; make the minibuffer less than 1
		       ;; line tall.
		       (if (and (> growth 0)
				(< (- (window-height minibuffer)
				      growth)
				   1))
			   (setq growth (1- (window-height minibuffer))))
		       (enlarge-window (- growth))
		       (select-window start-event-window))
		   ;; no.  grow/shrink the selected window
303
		   ;; (message "growth = %d" growth)
304
		   (enlarge-window growth))
305
		 
306 307 308 309 310 311 312 313 314 315 316 317
		 ;; if this window's growth caused another
		 ;; window to be deleted because it was too
		 ;; short, rescind the change.
		 ;;
		 ;; if size change caused space to be stolen
		 ;; from a window above this one, rescind the
		 ;; change, but only if we didn't grow/srhink
		 ;; the minibuffer.  minibuffer size changes
		 ;; can cause all windows to shrink... no way
		 ;; around it.
		 (if (or (/= start-nwindows (count-windows t))
			 (and (not should-enlarge-minibuffer)
318
			      mode-line-p
319 320
			      (/= top (nth 1 (window-edges)))))
		     (set-window-configuration wconfig)))))))))
321 322 323 324 325 326 327 328 329 330 331

(defun mouse-drag-mode-line (start-event)
  "Change the height of a window by dragging on the mode line."
  (interactive "e")
  (mouse-drag-mode-line-1 start-event t))

(defun mouse-drag-header-line (start-event)
  "Change the height of a window by dragging on the header line."
  (interactive "e")
  (mouse-drag-mode-line-1 start-event nil))

332

333 334 335 336 337
(defun mouse-drag-vertical-line (start-event)
  "Change the width of a window by dragging on the vertical line."
  (interactive "e")
  ;; Give temporary modes such as isearch a chance to turn off.
  (run-hooks 'mouse-leave-buffer-hook)
338 339 340 341 342 343 344 345 346 347
  (let* ((done nil)
	 (echo-keystrokes 0)
	 (start-event-frame (window-frame (car (car (cdr start-event)))))
	 (start-event-window (car (car (cdr start-event))))
	 (start-nwindows (count-windows t))
	 (old-selected-window (selected-window))
	 event mouse x left right edges wconfig growth
	 (which-side
	  (or (cdr (assq 'vertical-scroll-bars (frame-parameters start-event-frame)))
	      'right)))
348 349
    (if (one-window-p t)
	(error "Attempt to resize sole ordinary window"))
Karl Heuer's avatar
Karl Heuer committed
350 351 352 353 354 355
    (if (eq which-side 'right)
	(if (= (nth 2 (window-edges start-event-window))
	       (frame-width start-event-frame))
	    (error "Attempt to drag rightmost scrollbar"))
      (if (= (nth 0 (window-edges start-event-window)) 0)
	  (error "Attempt to drag leftmost scrollbar")))
356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392
    (track-mouse
      (progn
	;; enlarge-window only works on the selected window, so
	;; we must select the window where the start event originated.
	;; unwind-protect will restore the old selected window later.
	(select-window start-event-window)
	;; loop reading events and sampling the position of
	;; the mouse.
	(while (not done)
	  (setq event (read-event)
		mouse (mouse-position))
	  ;; do nothing if
	  ;;   - there is a switch-frame event.
	  ;;   - the mouse isn't in the frame that we started in
	  ;;   - the mouse isn't in any Emacs frame
	  ;; drag if
	  ;;   - there is a mouse-movement event
	  ;;   - there is a scroll-bar-movement event
	  ;;     (same as mouse movement for our purposes)
	  ;; quit if
	  ;;   - there is a keyboard event or some other unknown event
	  ;;     unknown event.
	  (cond ((integerp event)
		 (setq done t))
		((eq (car event) 'switch-frame)
		 nil)
		((not (memq (car event)
			    '(mouse-movement scroll-bar-movement)))
		 (if (consp event)
		     (setq unread-command-events
			   (cons event unread-command-events)))
		 (setq done t))
		((not (eq (car mouse) start-event-frame))
		 nil)
		((null (car (cdr mouse)))
		 nil)
		(t
393 394 395
		 (save-selected-window
		   ;; If the scroll bar is on the window's left,
		   ;; adjust the window on the left.
Karl Heuer's avatar
Karl Heuer committed
396 397
		   (unless (eq which-side 'right)
		     (select-window (previous-window)))
398
		   (setq x (- (car (cdr mouse))
Karl Heuer's avatar
Karl Heuer committed
399
			      (if (eq which-side 'right) 0 2))
400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420
			 edges (window-edges)
			 left (nth 0 edges)
			 right (nth 2 edges))
		   ;; scale back a move that would make the
		   ;; window too thin.
		   (if (< (- x left -1) window-min-width)
		       (setq x (+ left window-min-width -1)))
		   ;; compute size change needed
		   (setq growth (- x right -1)
			 wconfig (current-window-configuration))
		   (enlarge-window growth t)
		   ;; if this window's growth caused another
		   ;; window to be deleted because it was too
		   ;; thin, rescind the change.
		   ;;
		   ;; if size change caused space to be stolen
		   ;; from a window to the left of this one,
		   ;; rescind the change.
		   (if (or (/= start-nwindows (count-windows t))
			   (/= left (nth 0 (window-edges))))
		       (set-window-configuration wconfig))))))))))
421

422
(defun mouse-set-point (event)
Jim Blandy's avatar
Jim Blandy committed
423
  "Move point to the position clicked on with the mouse.
424
This should be bound to a mouse click event type."
Jim Blandy's avatar
Jim Blandy committed
425
  (interactive "e")
426
  (mouse-minibuffer-check event)
427 428 429
  ;; Use event-end in case called from mouse-drag-region.
  ;; If EVENT is a click, event-end and event-start give same value.
  (let ((posn (event-end event)))
430 431
    (if (not (windowp (posn-window posn)))
	(error "Cursor not in text area of window"))
432 433 434
    (select-window (posn-window posn))
    (if (numberp (posn-point posn))
	(goto-char (posn-point posn)))))
Jim Blandy's avatar
Jim Blandy committed
435

436 437 438 439 440 441 442 443 444 445 446
(defvar mouse-last-region-beg nil)
(defvar mouse-last-region-end nil)
(defvar mouse-last-region-tick nil)

(defun mouse-region-match ()
  "Return non-nil if there's an active region that was set with the mouse."
  (and (mark t) mark-active
       (eq mouse-last-region-beg (region-beginning))
       (eq mouse-last-region-end (region-end))
       (eq mouse-last-region-tick (buffer-modified-tick))))

447
(defun mouse-set-region (click)
448
  "Set the region to the text dragged over, and copy to kill ring.
449
This should be bound to a mouse drag event."
450
  (interactive "e")
451
  (mouse-minibuffer-check click)
452 453 454 455 456
  (let ((posn (event-start click))
	(end (event-end click)))
    (select-window (posn-window posn))
    (if (numberp (posn-point posn))
	(goto-char (posn-point posn)))
457
    ;; If mark is highlighted, no need to bounce the cursor.
458 459
    ;; On X, we highlight while dragging, thus once again no need to bounce.
    (or transient-mark-mode
460
	(memq (framep (selected-frame)) '(x pc w32))
461
	(sit-for 1))
462
    (push-mark)
463
    (set-mark (point))
464
    (if (numberp (posn-point end))
465 466 467
	(goto-char (posn-point end)))
    ;; Don't set this-command to kill-region, so that a following
    ;; C-w will not double the text in the kill ring.
468
    ;; Ignore last-command so we don't append to a preceding kill.
469
    (let (this-command last-command deactivate-mark)
470 471 472 473 474 475 476
      (copy-region-as-kill (mark) (point)))
    (mouse-set-region-1)))

(defun mouse-set-region-1 ()
  (setq mouse-last-region-beg (region-beginning))
  (setq mouse-last-region-end (region-end))
  (setq mouse-last-region-tick (buffer-modified-tick)))
477

Richard M. Stallman's avatar
Richard M. Stallman committed
478
(defcustom mouse-scroll-delay 0.25
479 480 481 482 483 484
  "*The pause between scroll steps caused by mouse drags, in seconds.
If you drag the mouse beyond the edge of a window, Emacs scrolls the
window to bring the text beyond that edge into view, with a delay of
this many seconds between scroll steps.  Scrolling stops when you move
the mouse back into the window, or release the button.
This variable's value may be non-integral.
Richard M. Stallman's avatar
Richard M. Stallman committed
485 486 487
Setting this to zero causes Emacs to scroll as fast as it can."
  :type 'number
  :group 'mouse)
488

Richard M. Stallman's avatar
Richard M. Stallman committed
489
(defcustom mouse-scroll-min-lines 1
490 491 492 493 494
  "*The minimum number of lines scrolled by dragging mouse out of window.
Moving the mouse out the top or bottom edge of the window begins
scrolling repeatedly.  The number of lines scrolled per repetition
is normally equal to the number of lines beyond the window edge that
the mouse has moved.  However, it always scrolls at least the number
Richard M. Stallman's avatar
Richard M. Stallman committed
495 496 497
of lines specified by this variable."
  :type 'integer
  :group 'mouse)
498

499 500
(defun mouse-scroll-subr (window jump &optional overlay start)
  "Scroll the window WINDOW, JUMP lines at a time, until new input arrives.
501 502 503
If OVERLAY is an overlay, let it stretch from START to the far edge of
the newly visible text.
Upon exit, point is at the far edge of the newly visible text."
504 505 506 507 508
  (cond
   ((and (> jump 0) (< jump mouse-scroll-min-lines))
    (setq jump mouse-scroll-min-lines))
   ((and (< jump 0) (< (- jump) mouse-scroll-min-lines))
    (setq jump (- mouse-scroll-min-lines))))
509 510 511 512 513 514 515
  (let ((opoint (point)))
    (while (progn
	     (goto-char (window-start window))
	     (if (not (zerop (vertical-motion jump window)))
		 (progn
		   (set-window-start window (point))
		   (if (natnump jump)
516 517 518 519 520 521 522
		       (if (window-end window)
			   (progn
			     (goto-char (window-end window))
			     ;; window-end doesn't reflect the window's new
			     ;; start position until the next redisplay.
			     (vertical-motion (1- jump) window))
			 (vertical-motion (- (window-height window) 2)))
523 524 525 526 527 528 529 530
		     (goto-char (window-start window)))
		   (if overlay
		       (move-overlay overlay start (point)))
		   ;; Now that we have scrolled WINDOW properly,
		   ;; put point back where it was for the redisplay
		   ;; so that we don't mess up the selected window.
		   (or (eq window (selected-window))
		       (goto-char opoint))
531
		   (sit-for mouse-scroll-delay)))))
532 533
    (or (eq window (selected-window))
	(goto-char opoint))))
534

535
;; Create an overlay and immediately delete it, to get "overlay in no buffer".
536
(defvar mouse-drag-overlay (make-overlay 1 1))
537
(delete-overlay mouse-drag-overlay)
538 539
(overlay-put mouse-drag-overlay 'face 'region)

540
(defvar mouse-selection-click-count 0)
541

542 543
(defvar mouse-selection-click-count-buffer nil)

544
(defun mouse-drag-region (start-event)
545
  "Set the region to the text that the mouse is dragged over.
546 547
Highlight the drag area as you move the mouse.
This must be bound to a button-down mouse event.
548 549
In Transient Mark mode, the highlighting remains as long as the mark
remains active.  Otherwise, it remains until the next input event."
550
  (interactive "e")
551
  (mouse-minibuffer-check start-event)
552 553
  (let* ((echo-keystrokes 0)
	 (start-posn (event-start start-event))
554 555
	 (start-point (posn-point start-posn))
	 (start-window (posn-window start-posn))
556
	 (start-frame (window-frame start-window))
557
	 (start-hscroll (window-hscroll start-window))
558 559 560 561 562
	 (bounds (window-edges start-window))
	 (top (nth 1 bounds))
	 (bottom (if (window-minibuffer-p start-window)
		     (nth 3 bounds)
		   ;; Don't count the mode line.
563 564
		   (1- (nth 3 bounds))))
	 (click-count (1- (event-click-count start-event))))
565
    (setq mouse-selection-click-count click-count)
566
    (setq mouse-selection-click-count-buffer (current-buffer))
567
    (mouse-set-point start-event)
568 569 570 571 572
    ;; In case the down click is in the middle of some intangible text,
    ;; use the end of that text, and put it in START-POINT.
    (if (< (point) start-point)
	(goto-char start-point))
    (setq start-point (point))
573 574 575
    (let ((range (mouse-start-end start-point start-point click-count)))
      (move-overlay mouse-drag-overlay (car range) (nth 1 range)
		    (window-buffer start-window)))
576
    (deactivate-mark)
577 578 579
    ;; end-of-range is used only in the single-click case.
    ;; It is the place where the drag has reached so far
    ;; (but not outside the window where the drag started).
580
    (let (event end end-point last-end-point (end-of-range (point)))
581
      (track-mouse
582
	(while (progn
583 584 585 586 587 588 589
		 (setq event (read-event))
		 (or (mouse-movement-p event)
		     (eq (car-safe event) 'switch-frame)))
	  (if (eq (car-safe event) 'switch-frame)
	      nil
	    (setq end (event-end event)
		  end-point (posn-point end))
590
	    (if (numberp end-point)
591
		(setq last-end-point end-point))
592 593 594 595 596

	    (cond
	     ;; Are we moving within the original window?
	     ((and (eq (posn-window end) start-window)
		   (integer-or-marker-p end-point))
597 598 599 600
	      ;; Go to START-POINT first, so that when we move to END-POINT,
	      ;; if it's in the middle of intangible text,
	      ;; point jumps in the direction away from START-POINT.
	      (goto-char start-point)
601
	      (goto-char end-point)
602 603
	      (if (zerop (% click-count 3))
		  (setq end-of-range (point)))
604 605
	      (let ((range (mouse-start-end start-point (point) click-count)))
		(move-overlay mouse-drag-overlay (car range) (nth 1 range))))
606

607 608
	     (t
	      (let ((mouse-row (cdr (cdr (mouse-position)))))
609
		(cond
610
		 ((null mouse-row))
611
		 ((< mouse-row top)
612
		  (mouse-scroll-subr start-window (- mouse-row top)
613 614 615 616
				     mouse-drag-overlay start-point)
		  ;; Without this, point tends to jump back to the starting
		  ;; position where the mouse button was pressed down.
		  (setq end-of-range (overlay-start mouse-drag-overlay)))
617
		 ((>= mouse-row bottom)
618
		  (mouse-scroll-subr start-window (1+ (- mouse-row bottom))
619
				     mouse-drag-overlay start-point)
620
		  (setq end-of-range (overlay-end mouse-drag-overlay))))))))))
621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639
      ;; In case we did not get a mouse-motion event
      ;; for the final move of the mouse before a drag event
      ;; pretend that we did get one.
      (when (and (memq 'drag (event-modifiers (car-safe event)))
		 (setq end (event-end event)
		       end-point (posn-point end))
		 (eq (posn-window end) start-window)
		 (integer-or-marker-p end-point))

	;; Go to START-POINT first, so that when we move to END-POINT,
	;; if it's in the middle of intangible text,
	;; point jumps in the direction away from START-POINT.
	(goto-char start-point)
	(goto-char end-point)
	(if (zerop (% click-count 3))
	    (setq end-of-range (point)))
	(let ((range (mouse-start-end start-point (point) click-count)))
	  (move-overlay mouse-drag-overlay (car range) (nth 1 range))))

640
      (if (consp event)
641
	  (let ((fun (key-binding (vector (car event)))))
642 643 644
	    ;; Run the binding of the terminating up-event, if possible.
	    ;; In the case of a multiple click, it gives the wrong results,
	    ;; because it would fail to set up a region.
645 646 647 648 649 650 651 652 653 654 655
	    (if (not (= (overlay-start mouse-drag-overlay)
			(overlay-end mouse-drag-overlay)))
		(let* ((stop-point
			(if (numberp (posn-point (event-end event)))
			    (posn-point (event-end event))
			  last-end-point))
		       ;; The end that comes from where we ended the drag.
		       ;; Point goes here.
		       (region-termination
			(if (and stop-point (< stop-point start-point))
			    (overlay-start mouse-drag-overlay)
656
			  (overlay-end mouse-drag-overlay)))
657 658 659 660 661 662 663 664 665
		       ;; The end that comes from where we started the drag.
		       ;; Mark goes there.
		       (region-commencement
			(- (+ (overlay-end mouse-drag-overlay)
			      (overlay-start mouse-drag-overlay))
			   region-termination))
		       last-command this-command)
		  (push-mark region-commencement t t)
		  (goto-char region-termination)
666 667 668
		  ;; Don't let copy-region-as-kill set deactivate-mark.
		  (let (deactivate-mark)
		    (copy-region-as-kill (point) (mark t)))
669 670 671 672 673 674 675 676 677 678 679
		  (let ((buffer (current-buffer)))
		    (mouse-show-mark)
		    ;; mouse-show-mark can call read-event,
		    ;; and that means the Emacs server could switch buffers
		    ;; under us.  If that happened, 
		    ;; avoid trying to use the region.
		    (and (mark t) mark-active
			 (eq buffer (current-buffer))
			 (mouse-set-region-1))))
	      (delete-overlay mouse-drag-overlay)
	      ;; Run the binding of the terminating up-event.
680 681 682 683
	      (when (and (fboundp fun)
			 (= start-hscroll (window-hscroll start-window)))
		(setq unread-command-events
		      (cons event unread-command-events)))))
684
	(delete-overlay mouse-drag-overlay)))))
685 686

;; Commands to handle xterm-style multiple clicks.
687

688 689 690 691 692
(defun mouse-skip-word (dir)
  "Skip over word, over whitespace, or over identical punctuation.
If DIR is positive skip forward; if negative, skip backward."
  (let* ((char (following-char))
	 (syntax (char-to-string (char-syntax char))))
693 694 695 696 697 698 699 700 701 702 703 704
    (cond ((string= syntax "w")
	   ;; Here, we can't use skip-syntax-forward/backward because
	   ;; they don't pay attention to word-separating-categories,
	   ;; and thus they will skip over a true word boundary.  So,
	   ;; we simularte the original behaviour by using
	   ;; forward-word.
	   (if (< dir 0)
	       (if (not (looking-at "\\<"))
		   (forward-word -1))
	     (if (or (looking-at "\\<") (not (looking-at "\\>")))
		 (forward-word 1))))
	  ((string= syntax " ")
705 706 707 708 709 710 711 712 713 714 715 716 717
	   (if (< dir 0)
	       (skip-syntax-backward syntax)
	     (skip-syntax-forward syntax)))
	  ((string= syntax "_")
	   (if (< dir 0)
	       (skip-syntax-backward "w_")
	     (skip-syntax-forward "w_")))
	  ((< dir 0)
	   (while (and (not (bobp)) (= (preceding-char) char))
	     (forward-char -1)))
	  (t
	   (while (and (not (eobp)) (= (following-char) char))
	     (forward-char 1))))))
718 719 720 721 722 723

;; Return a list of region bounds based on START and END according to MODE.
;; If MODE is 0 then set point to (min START END), mark to (max START END).
;; If MODE is 1 then set point to start of word at (min START END),
;; mark to end of word at (max START END).
;; If MODE is 2 then do the same for lines.
724
(defun mouse-start-end (start end mode)
725 726 727 728
  (if (> start end)
      (let ((temp start))
        (setq start end
              end temp)))
729
  (setq mode (mod mode 3))
730 731 732 733
  (cond ((= mode 0)
	 (list start end))
        ((and (= mode 1)
              (= start end)
734
	      (char-after start)
735
              (= (char-syntax (char-after start)) ?\())
736 737 738 739 740
	 (list start
	       (save-excursion
		 (goto-char start)
		 (forward-sexp 1)
		 (point))))
741 742
        ((and (= mode 1)
              (= start end)
743
	      (char-after start)
744 745 746
              (= (char-syntax (char-after start)) ?\)))
	 (list (save-excursion 
		 (goto-char (1+ start))
747 748
		 (backward-sexp 1)
		 (point))
749
	       (1+ start)))
750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766
	((and (= mode 1)
              (= start end)
	      (char-after start)
              (= (char-syntax (char-after start)) ?\"))
	 (let ((open (or (eq start (point-min))
			 (save-excursion
			   (goto-char (- start 1))
			   (looking-at "\\s(\\|\\s \\|\\s>")))))
	   (if open
	       (list start
		     (save-excursion
		       (condition-case nil
			   (progn 
			     (goto-char start)
			     (forward-sexp 1)
			     (point))
			 (error end))))
767
	     (list (save-excursion
768 769 770 771 772
		     (condition-case nil
			 (progn
			   (goto-char (1+ start))
			   (backward-sexp 1)
			   (point))
773 774
		       (error end)))
		   (1+ start)))))
775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792
        ((= mode 1)
	 (list (save-excursion
		 (goto-char start)
		 (mouse-skip-word -1)
		 (point))
	       (save-excursion
		 (goto-char end)
		 (mouse-skip-word 1)
		 (point))))
        ((= mode 2)
	 (list (save-excursion
		 (goto-char start)
		 (beginning-of-line 1)
		 (point))
	       (save-excursion
		 (goto-char end)
		 (forward-line 1)
		 (point))))))
793

794 795 796
;; Subroutine: set the mark where CLICK happened,
;; but don't do anything else.
(defun mouse-set-mark-fast (click)
797
  (mouse-minibuffer-check click)
798 799 800 801 802
  (let ((posn (event-start click)))
    (select-window (posn-window posn))
    (if (numberp (posn-point posn))
	(push-mark (posn-point posn) t t))))

803 804 805 806 807
(defun mouse-undouble-last-event (events)
  (let* ((index (1- (length events)))
	 (last (nthcdr index events))
	 (event (car last))
	 (basic (event-basic-type event))
808 809
	 (old-modifiers (event-modifiers event))
	 (modifiers (delq 'double (delq 'triple (copy-sequence old-modifiers))))
810 811
	 (new
	  (if (consp event)
812 813
	      ;; Use reverse, not nreverse, since event-modifiers
	      ;; does not copy the list it returns.
814
	      (cons (event-convert-list (reverse (cons basic modifiers)))
815 816 817
		    (cdr event))
	    event)))
    (setcar last new)
818 819
    (if (and (not (equal modifiers old-modifiers))
	     (key-binding (apply 'vector events)))
820 821 822 823
	t
      (setcar last event)
      nil)))

824
;; Momentarily show where the mark is, if highlighting doesn't show it. 
825 826 827 828

(defvar mouse-region-delete-keys '([delete])
  "List of keys which shall cause the mouse region to be deleted.")

829
(defun mouse-show-mark ()
830
  (if transient-mark-mode
831
      (if window-system
832 833 834 835
	  (delete-overlay mouse-drag-overlay))
    (if window-system
	(let ((inhibit-quit t)
	      (echo-keystrokes 0)
836 837 838 839 840 841 842
	      event events key ignore
	      x-lost-selection-hooks)
	  (add-hook 'x-lost-selection-hooks
		    '(lambda (seltype)
		       (if (eq seltype 'PRIMARY)
			   (progn (setq ignore t)
				  (throw 'mouse-show-mark t)))))
843
	  (move-overlay mouse-drag-overlay (point) (mark t))
844
	  (catch 'mouse-show-mark
845 846
	    ;; In this loop, execute scroll bar and switch-frame events.
	    ;; Also ignore down-events that are undefined.
847 848 849
	    (while (progn (setq event (read-event))
			  (setq events (append events (list event)))
			  (setq key (apply 'vector events))
850
			  (or (and (consp event)
851 852
				   (eq (car event) 'switch-frame))
			      (and (consp event)
853 854 855 856 857 858 859
				   (eq (posn-point (event-end event))
				       'vertical-scroll-bar))
			      (and (memq 'down (event-modifiers event))
				   (not (key-binding key))
				   (not (mouse-undouble-last-event events))
				   (not (member key mouse-region-delete-keys)))))
	      (and (consp event)
860 861 862
		   (or (eq (car event) 'switch-frame)
		       (eq (posn-point (event-end event))
			   'vertical-scroll-bar))
863 864 865 866 867 868
		   (let ((keys (vector 'vertical-scroll-bar event)))
		     (and (key-binding keys)
			  (progn
			    (call-interactively (key-binding keys)
						nil keys)
			    (setq events nil)))))))
869 870 871 872 873 874 875 876 877 878
	  ;; If we lost the selection, just turn off the highlighting.
	  (if ignore
	      nil
	    ;; For certain special keys, delete the region.
	    (if (member key mouse-region-delete-keys)
		(delete-region (overlay-start mouse-drag-overlay)
			       (overlay-end mouse-drag-overlay))
	      ;; Otherwise, unread the key so it gets executed normally.
	      (setq unread-command-events
		    (nconc events unread-command-events))))
879 880 881 882 883
	  (setq quit-flag nil)
	  (delete-overlay mouse-drag-overlay))
      (save-excursion
       (goto-char (mark t))
       (sit-for 1)))))
884

Jim Blandy's avatar
Jim Blandy committed
885 886 887 888
(defun mouse-set-mark (click)
  "Set mark at the position clicked on with the mouse.
Display cursor at that position for a second.
This must be bound to a mouse click."
Jim Blandy's avatar
Jim Blandy committed
889
  (interactive "e")
890 891 892
  (mouse-minibuffer-check click)
  (select-window (posn-window (event-start click)))
  ;; We don't use save-excursion because that preserves the mark too.
Richard M. Stallman's avatar
Richard M. Stallman committed
893 894
  (let ((point-save (point)))
    (unwind-protect
Jim Blandy's avatar
Jim Blandy committed
895
	(progn (mouse-set-point click)
896 897 898
	       (push-mark nil t t)
	       (or transient-mark-mode
		   (sit-for 1)))
Richard M. Stallman's avatar
Richard M. Stallman committed
899 900
      (goto-char point-save))))

Jim Blandy's avatar
Jim Blandy committed
901 902 903
(defun mouse-kill (click)
  "Kill the region between point and the mouse click.
The text is saved in the kill ring, as with \\[kill-region]."
Jim Blandy's avatar
Jim Blandy committed
904
  (interactive "e")
905
  (mouse-minibuffer-check click)
906 907 908
  (let* ((posn (event-start click))
	 (click-posn (posn-point posn)))
    (select-window (posn-window posn))
Jim Blandy's avatar
Jim Blandy committed
909 910 911
    (if (numberp click-posn)
	(kill-region (min (point) click-posn)
		     (max (point) click-posn)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
912

Jim Blandy's avatar
Jim Blandy committed
913 914
(defun mouse-yank-at-click (click arg)
  "Insert the last stretch of killed text at the position clicked on.
915 916
Also move point to one end of the text thus inserted (normally the end),
and set mark at the beginning..
917 918 919
Prefix arguments are interpreted as with \\[yank].
If `mouse-yank-at-point' is non-nil, insert at point
regardless of where you click."
Jim Blandy's avatar
Jim Blandy committed
920
  (interactive "e\nP")
921 922
  ;; Give temporary modes such as isearch a chance to turn off.
  (run-hooks 'mouse-leave-buffer-hook)
923
  (or mouse-yank-at-point (mouse-set-point click))
924
  (setq this-command 'yank)
925
  (setq mouse-selection-click-count 0)
Jim Blandy's avatar
Jim Blandy committed
926 927 928
  (yank arg))

(defun mouse-kill-ring-save (click)
Jim Blandy's avatar
Jim Blandy committed
929 930
  "Copy the region between point and the mouse click in the kill ring.
This does not delete the region; it acts like \\[kill-ring-save]."
Jim Blandy's avatar
Jim Blandy committed
931
  (interactive "e")
932
  (mouse-set-mark-fast click)
933 934
  (let (this-command last-command)
    (kill-ring-save (point) (mark t)))
935
  (mouse-show-mark))
Richard M. Stallman's avatar
Richard M. Stallman committed
936

Jim Blandy's avatar
Jim Blandy committed
937 938 939 940 941 942 943 944
;;; This function used to delete the text between point and the mouse
;;; whenever it was equal to the front of the kill ring, but some
;;; people found that confusing.

;;; A list (TEXT START END), describing the text and position of the last
;;; invocation of mouse-save-then-kill.
(defvar mouse-save-then-kill-posn nil)

945
(defun mouse-save-then-kill-delete-region (beg end)
946 947 948
  ;; We must make our own undo boundaries
  ;; because they happen automatically only for the current buffer.
  (undo-boundary)
949 950 951 952 953 954 955
  (if (or (= beg end) (eq buffer-undo-list t))
      ;; If we have no undo list in this buffer,
      ;; just delete.
      (delete-region beg end)
    ;; Delete, but make the undo-list entry share with the kill ring.
    ;; First, delete just one char, so in case buffer is being modified
    ;; for the first time, the undo list records that fact.
956
    (let (before-change-functions after-change-functions)
957 958
      (delete-region beg
		     (+ beg (if (> end beg) 1 -1))))
959 960
    (let ((buffer-undo-list buffer-undo-list))
      ;; Undo that deletion--but don't change the undo list!
961
      (let (before-change-functions after-change-functions)
962
	(primitive-undo 1 buffer-undo-list))
963 964 965
      ;; Now delete the rest of the specified region,
      ;; but don't record it.
      (setq buffer-undo-list t)
966 967
      (if (/= (length (car kill-ring)) (- (max end beg) (min end beg)))
	  (error "Lossage in mouse-save-then-kill-delete-region"))
968 969 970 971 972 973 974 975
      (delete-region beg end))
    (let ((tail buffer-undo-list))
      ;; Search back in buffer-undo-list for the string
      ;; that came from deleting one character.
      (while (and tail (not (stringp (car (car tail)))))
	(setq tail (cdr tail)))
      ;; Replace it with an entry for the entire deleted text.
      (and tail
976 977
	   (setcar tail (cons (car kill-ring) (min beg end))))))
  (undo-boundary))
978

979
(defun mouse-save-then-kill (click)
980 981 982 983
  "Save text to point in kill ring; the second time, kill the text.
If the text between point and the mouse is the same as what's
at the front of the kill ring, this deletes the text.
Otherwise, it adds the text to the kill ring, like \\[kill-ring-save],
984 985 986 987 988 989
which prepares for a second click to delete the text.

If you have selected words or lines, this command extends the
selection through the word or line clicked on.  If you do this
again in a different position, it extends the selection again.
If you do this twice in the same position, the selection is killed." 
990
  (interactive "e")
991 992 993
  (let ((before-scroll
	 (with-current-buffer (window-buffer (posn-window (event-start click)))
	   point-before-scroll)))
994 995 996 997 998
    (mouse-minibuffer-check click)
    (let ((click-posn (posn-point (event-start click)))
	  ;; Don't let a subsequent kill command append to this one:
	  ;; prevent setting this-command to kill-region.
	  (this-command this-command))
999 1000 1001 1002 1003 1004
      (if (and (save-excursion
		 (set-buffer (window-buffer (posn-window (event-start click))))
		 (and (mark t) (> (mod mouse-selection-click-count 3) 0)
		      ;; Don't be fooled by a recent click in some other buffer.
		      (eq mouse-selection-click-count-buffer 
			  (current-buffer)))))
1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021
	  (if (not (and (eq last-command 'mouse-save-then-kill)
			(equal click-posn
			       (car (cdr-safe (cdr-safe mouse-save-then-kill-posn))))))
	      ;; Find both ends of the object selected by this click.
	      (let* ((range
		      (mouse-start-end click-posn click-posn
				       mouse-selection-click-count)))
		;; Move whichever end is closer to the click.
		;; That's what xterm does, and it seems reasonable.
		(if (< (abs (- click-posn (mark t)))
		       (abs (- click-posn (point))))
		    (set-mark (car range))
		  (goto-char (nth 1 range)))
		;; We have already put the old region in the kill ring.
		;; Replace it with the extended region.
		;; (It would be annoying to make a separate entry.)
		(kill-new (buffer-substring (point) (mark t)) t)
1022
		(mouse-set-region-1)
1023 1024 1025 1026 1027 1028
		;; Arrange for a repeated mouse-3 to kill this region.
		(setq mouse-save-then-kill-posn
		      (list (car kill-ring) (point) click-posn))
		(mouse-show-mark))
	    ;; If we click this button again without moving it,
	    ;; that time kill.
1029
	    (mouse-save-then-kill-delete-region (mark) (point))
1030
	    (setq mouse-selection-click-count 0)
1031
	    (setq mouse-save-then-kill-posn nil))
1032 1033 1034 1035 1036 1037 1038 1039 1040 1041
	(if (and (eq last-command 'mouse-save-then-kill)
		 mouse-save-then-kill-posn
		 (eq (car mouse-save-then-kill-posn) (car kill-ring))
		 (equal (cdr mouse-save-then-kill-posn) (list (point) click-posn)))
	    ;; If this is the second time we've called
	    ;; mouse-save-then-kill, delete the text from the buffer.
	    (progn
	      (mouse-save-then-kill-delete-region (point) (mark))
	      ;; After we kill, another click counts as "the first time".
	      (setq mouse-save-then-kill-posn nil))
1042 1043
	  ;; This is not a repetition.
	  ;; We are adjusting an old selection or creating a new one.
1044 1045 1046 1047 1048 1049