mouse.el 77.7 KB
Newer Older
1
;;; mouse.el --- window system-independent mouse support  -*- lexical-binding: t -*-
Eric S. Raymond's avatar
Eric S. Raymond committed
2

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 1993-1995, 1999-2016 Free Software Foundation, Inc.
Eric S. Raymond's avatar
Eric S. Raymond committed
4

5
;; Maintainer: emacs-devel@gnu.org
6
;; Keywords: hardware, mouse
7
;; Package: emacs
Eric S. Raymond's avatar
Eric S. Raymond committed
8

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

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

Richard M. Stallman's avatar
Richard M. Stallman committed
16 17 18 19
;; 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
20

Richard M. Stallman's avatar
Richard M. Stallman committed
21
;; You should have received a copy of the GNU General Public License
22
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
Richard M. Stallman's avatar
Richard M. Stallman committed
23

24 25 26 27 28 29
;;; 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.

30 31
;;; Code:

Jim Blandy's avatar
Jim Blandy committed
32
;;; Utility functions.
Richard M. Stallman's avatar
Richard M. Stallman committed
33

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

Richard M. Stallman's avatar
Richard M. Stallman committed
37
(defcustom mouse-yank-at-point nil
Lute Kamstra's avatar
Lute Kamstra committed
38
  "If non-nil, mouse yank commands yank at point instead of at click."
Richard M. Stallman's avatar
Richard M. Stallman committed
39 40
  :type 'boolean
  :group 'mouse)
41

42
(defcustom mouse-drag-copy-region nil
43 44 45 46
  "If non-nil, copy to kill-ring upon mouse adjustments of the region.

This affects `mouse-save-then-kill' (\\[mouse-save-then-kill]) in
addition to mouse drags."
47
  :type 'boolean
48
  :version "24.1"
49 50
  :group 'mouse)

51
(defcustom mouse-1-click-follows-link 450
52
  "Non-nil means that clicking Mouse-1 on a link follows the link.
53

54 55
With the default setting, an ordinary Mouse-1 click on a link
performs the same action as Mouse-2 on that link, while a longer
56
Mouse-1 click \(hold down the Mouse-1 button for more than 450
57
milliseconds) performs the original Mouse-1 binding \(which
58 59 60 61
typically sets point where you click the mouse).

If value is an integer, the time elapsed between pressing and
releasing the mouse button determines whether to follow the link
62
or perform the normal Mouse-1 action (typically set point).
Paul Eggert's avatar
Paul Eggert committed
63
The absolute numeric value specifies the maximum duration of a
64 65
\"short click\" in milliseconds.  A positive value means that a
short click follows the link, and a longer click performs the
66
normal action.  A negative value gives the opposite behavior.
67 68 69

If value is `double', a double click follows the link.

70
Otherwise, a single Mouse-1 click unconditionally follows the link.
71 72 73 74 75 76

Note that dragging the mouse never follows the link.

This feature only works in modes that specifically identify
clickable text as links, so it may not work with some external
packages.  See `mouse-on-link-p' for details."
77
  :version "22.1"
78 79
  :type '(choice (const :tag "Disabled" nil)
		 (const :tag "Double click" double)
80
                 (number :tag "Single click time limit" :value 450)
81 82 83
                 (other :tag "Single click" t))
  :group 'mouse)

84
(defcustom mouse-1-click-in-non-selected-windows t
Lute Kamstra's avatar
Lute Kamstra committed
85
  "If non-nil, a Mouse-1 click also follows links in non-selected windows.
86 87 88 89 90 91 92 93

If nil, a Mouse-1 click on a link in a non-selected window performs
the normal mouse-1 binding, typically selects the window and sets
point at the click position."
  :type 'boolean
  :version "22.1"
  :group 'mouse)

94 95 96
(defun mouse--down-1-maybe-follows-link (&optional _prompt)
  "Turn `mouse-1' events into `mouse-2' events if follows-link.
Expects to be bound to `down-mouse-1' in `key-translation-map'."
97 98 99 100 101 102 103 104
  (when (and mouse-1-click-follows-link
             (eq (if (eq mouse-1-click-follows-link 'double)
                     'double-down-mouse-1 'down-mouse-1)
                 (car-safe last-input-event))
             (mouse-on-link-p (event-start last-input-event))
             (or mouse-1-click-in-non-selected-windows
                 (eq (selected-window)
                     (posn-window (event-start last-input-event)))))
105
    (let ((timedout
106 107 108 109 110 111 112 113
           (sit-for (if (numberp mouse-1-click-follows-link)
                     (/ (abs mouse-1-click-follows-link) 1000.0)
                     0))))
      (if (if (and (numberp mouse-1-click-follows-link)
                   (>= mouse-1-click-follows-link 0))
              timedout (not timedout))
          nil

114
        (let ((event (read-key))) ;Use read-key so it works for xterm-mouse-mode!
115 116 117 118
          (if (eq (car-safe event) (if (eq mouse-1-click-follows-link 'double)
                                       'double-mouse-1 'mouse-1))
              ;; Turn the mouse-1 into a mouse-2 to follow links.
              (let ((newup (if (eq mouse-1-click-follows-link 'double)
119
                                'double-mouse-2 'mouse-2)))
120 121
                ;; If mouse-2 has never been done by the user, it doesn't have
                ;; the necessary property to be interpreted correctly.
122 123
                (unless (get newup 'event-kind)
                  (put newup 'event-kind (get (car event) 'event-kind)))
124
                (push (cons newup (cdr event)) unread-command-events)
125 126
                ;; Don't change the down event, only the up-event (bug#18212).
                nil)
127 128 129 130 131 132 133
            (push event unread-command-events)
            nil))))))

(define-key key-translation-map [down-mouse-1]
  #'mouse--down-1-maybe-follows-link)
(define-key key-translation-map [double-down-mouse-1]
  #'mouse--down-1-maybe-follows-link)
134

Jim Blandy's avatar
Jim Blandy committed
135

136 137
;; Provide a mode-specific menu on a mouse button.

138
(defun minor-mode-menu-from-indicator (indicator)
139 140 141 142 143
  "Show menu for minor mode specified by INDICATOR.
Interactively, INDICATOR is read using completion.
If there is no menu defined for the minor mode, then create one with
items `Turn Off' and `Help'."
  (interactive
144
   (list (completing-read
145 146
	  "Minor mode indicator: "
	  (describe-minor-mode-completion-table-for-indicator))))
147 148
  (let* ((minor-mode (lookup-minor-mode-from-indicator indicator))
         (mm-fun (or (get minor-mode :minor-mode-function) minor-mode)))
149
    (unless minor-mode (error "Cannot find minor mode for `%s'" indicator))
150 151
    (let* ((map (cdr-safe (assq minor-mode minor-mode-map-alist)))
           (menu (and (keymapp map) (lookup-key map [menu-bar]))))
152 153 154
      (setq menu
            (if menu
                (mouse-menu-non-singleton menu)
155 156 157 158 159 160 161 162 163 164
              (if (fboundp mm-fun)      ; bug#20201
                  `(keymap
                    ,indicator
                    (turn-off menu-item "Turn Off minor mode" ,mm-fun)
                    (help menu-item "Help for minor mode"
                          (lambda () (interactive)
                            (describe-function ',mm-fun)))))))
      (if menu
          (popup-menu menu)
        (message "No menu available")))))
165 166 167 168 169 170 171

(defun mouse-minor-mode-menu (event)
  "Show minor-mode menu for EVENT on minor modes area of the mode line."
  (interactive "@e")
  (let ((indicator (car (nth 4 (car (cdr event))))))
    (minor-mode-menu-from-indicator indicator)))

172
(defun mouse-menu-major-mode-map ()
Glenn Morris's avatar
Glenn Morris committed
173
  (run-hooks 'activate-menubar-hook 'menu-bar-update-hook)
174 175
  (let* (;; Keymap from which to inherit; may be null.
	 (ancestor (mouse-menu-non-singleton
176
		    (and (current-local-map)
177
			 (local-key-binding [menu-bar]))))
178 179 180
	 ;; Make a keymap in which our last command leads to a menu or
	 ;; default to the edit menu.
	 (newmap (if ancestor
181 182
		     (make-sparse-keymap (concat (format-mode-line mode-name)
                                                 " Mode"))
183
		   menu-bar-edit-menu)))
184
    (if ancestor
185
	(set-keymap-parent newmap ancestor))
186
    newmap))
187

188
(defun mouse-menu-non-singleton (menubar)
189 190 191
  "Return menu keybar MENUBAR, or a lone submenu inside it.
If MENUBAR defines exactly one submenu, return just that submenu.
Otherwise, return MENUBAR."
192
  (if menubar
193 194 195
      (let (submap)
        (map-keymap
         (lambda (k v) (setq submap (if submap t (cons k v))))
196
         (keymap-canonicalize menubar))
197 198 199
        (if (eq submap t)
            menubar
          (lookup-key menubar (vector (car submap)))))))
200

201 202
(defun mouse-menu-bar-map ()
  "Return a keymap equivalent to the menu bar.
203 204
The contents are the items that would be in the menu bar whether or
not it is actually displayed."
Glenn Morris's avatar
Glenn Morris committed
205
  (run-hooks 'activate-menubar-hook 'menu-bar-update-hook)
206 207 208
  (let* ((local-menu (and (current-local-map)
			  (lookup-key (current-local-map) [menu-bar])))
	 (global-menu (lookup-key global-map [menu-bar]))
209 210 211 212 213 214 215
	 ;; If a keymap doesn't have a prompt string (a lazy
	 ;; programmer didn't bother to provide one), create it and
	 ;; insert it into the keymap; each keymap gets its own
	 ;; prompt.  This is required for non-toolkit versions to
	 ;; display non-empty menu pane names.
	 (minor-mode-menus
	  (mapcar
216 217 218 219 220 221 222 223 224 225 226 227 228 229
           (lambda (menu)
             (let* ((minor-mode (car menu))
                    (menu (cdr menu))
                    (title-or-map (cadr menu)))
               (or (stringp title-or-map)
                   (setq menu
                         (cons 'keymap
                               (cons (concat
                                      (capitalize (subst-char-in-string
                                                   ?- ?\s (symbol-name
                                                           minor-mode)))
                                      " Menu")
                                     (cdr menu)))))
               menu))
230
	   (minor-mode-key-binding [menu-bar])))
231 232 233 234 235
	 (local-title-or-map (and local-menu (cadr local-menu)))
	 (global-title-or-map (cadr global-menu)))
    (or (null local-menu)
	(stringp local-title-or-map)
	(setq local-menu (cons 'keymap
236
			       (cons (concat (format-mode-line mode-name)
237
                                             " Mode Menu")
238 239 240 241 242
				     (cdr local-menu)))))
    (or (stringp global-title-or-map)
	(setq global-menu (cons 'keymap
			        (cons "Global Menu"
				      (cdr global-menu)))))
243
    ;; Supplying the list is faster than making a new map.
244 245 246 247 248 249 250 251 252 253 254
    ;; FIXME: We have a problem here: we have to use the global/local/minor
    ;; so they're displayed in the expected order, but later on in the command
    ;; loop, they're actually looked up in the opposite order.
    (apply 'append
           global-menu
           local-menu
           minor-mode-menus)))

(defun mouse-major-mode-menu (event &optional prefix)
  "Pop up a mode-specific menu of mouse commands.
Default to the Edit menu if the major mode doesn't define a menu."
255
  (declare (obsolete mouse-menu-major-mode-map "23.1"))
256 257 258 259 260 261 262 263
  (interactive "@e\nP")
  (run-hooks 'activate-menubar-hook 'menu-bar-update-hook)
  (popup-menu (mouse-menu-major-mode-map) event prefix))

(defun mouse-popup-menubar (event prefix)
  "Pop up a menu equivalent to the menu bar for keyboard EVENT with PREFIX.
The contents are the items that would be in the menu bar whether or
not it is actually displayed."
264
  (declare (obsolete mouse-menu-bar-map "23.1"))
265 266
  (interactive "@e \nP")
  (run-hooks 'activate-menubar-hook 'menu-bar-update-hook)
267
  (popup-menu (mouse-menu-bar-map) (unless (integerp event) event) prefix))
268 269 270 271

(defun mouse-popup-menubar-stuff (event prefix)
  "Popup a menu like either `mouse-major-mode-menu' or `mouse-popup-menubar'.
Use the former if the menu bar is showing, otherwise the latter."
272
  (declare (obsolete nil "23.1"))
273 274 275 276 277 278 279
  (interactive "@e\nP")
  (run-hooks 'activate-menubar-hook 'menu-bar-update-hook)
  (popup-menu
   (if (zerop (or (frame-parameter nil 'menu-bar-lines) 0))
       (mouse-menu-bar-map)
     (mouse-menu-major-mode-map))
   event prefix))
280

281 282
;; Commands that operate on windows.

283 284 285 286
(defun mouse-minibuffer-check (event)
  (let ((w (posn-window (event-start event))))
    (and (window-minibuffer-p w)
	 (not (minibuffer-window-active-p w))
287
	 (user-error "Minibuffer window is not active")))
288 289
  ;; Give temporary modes such as isearch a chance to turn off.
  (run-hooks 'mouse-leave-buffer-hook))
290

Jim Blandy's avatar
Jim Blandy committed
291
(defun mouse-delete-window (click)
292
  "Delete the window you click on.
293
Do nothing if the frame has just one window.
294
This command must be bound to a mouse click."
Jim Blandy's avatar
Jim Blandy committed
295
  (interactive "e")
296
  (unless (one-window-p t)
297 298
    (mouse-minibuffer-check click)
    (delete-window (posn-window (event-start click)))))
Jim Blandy's avatar
Jim Blandy committed
299

300 301 302
(defun mouse-select-window (click)
  "Select the window clicked on; don't move point."
  (interactive "e")
303
  (mouse-minibuffer-check click)
304 305 306 307 308 309
  (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)
310
	(set-mouse-position (selected-frame) (1- (frame-width)) 0))))
311

312 313 314
(define-obsolete-function-alias 'mouse-tear-off-window 'tear-off-window "24.4")
(defun tear-off-window (click)
  "Delete the selected window, and create a new frame displaying its buffer."
315
  (interactive "e")
316
  (mouse-minibuffer-check click)
317 318
  (let* ((window (posn-window (event-start click)))
	 (buf (window-buffer window))
319
	 (frame (make-frame)))          ;FIXME: Use pop-to-buffer.
320 321 322 323
    (select-frame frame)
    (switch-to-buffer buf)
    (delete-window window)))

324
(defun mouse-delete-other-windows ()
325
  "Delete all windows except the one you click on."
326
  (interactive "@")
Jim Blandy's avatar
Jim Blandy committed
327
  (delete-other-windows))
Richard M. Stallman's avatar
Richard M. Stallman committed
328

Jim Blandy's avatar
Jim Blandy committed
329 330 331 332
(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."
333
  (interactive "@e")
334
  (mouse-minibuffer-check click)
335 336
  (let ((start (event-start click)))
    (select-window (posn-window start))
337
    (let ((new-height (1+ (cdr (posn-col-row (event-end click)))))
338 339 340
	  (first-line window-min-height)
	  (last-line (- (window-height) window-min-height)))
      (if (< last-line first-line)
341 342 343 344 345 346
	  (user-error "Window too short to split")
        ;; Bind `window-combination-resize' to nil so we are sure to get
        ;; the split right at the line clicked on.
        (let (window-combination-resize)
          (split-window-vertically
           (min (max new-height first-line) last-line)))))))
Jim Blandy's avatar
Jim Blandy committed
347

348 349 350 351 352
(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")
353
  (mouse-minibuffer-check click)
354 355 356 357 358 359
  (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)
360 361 362 363 364 365
	  (user-error "Window too narrow to split")
        ;; Bind `window-combination-resize' to nil so we are sure to get
        ;; the split right at the column clicked on.
	(let (window-combination-resize)
          (split-window-horizontally
           (min (max new-width first-col) last-col)))))))
366

367
(defun mouse-drag-line (start-event line)
368
  "Drag a mode line, header line, or vertical line with the mouse.
369
START-EVENT is the starting mouse-event of the drag action.  LINE
370
must be one of the symbols `header', `mode', or `vertical'."
371 372
  ;; Give temporary modes such as isearch a chance to turn off.
  (run-hooks 'mouse-leave-buffer-hook)
373
  (let* ((echo-keystrokes 0)
374
	 (start (event-start start-event))
375 376
	 (window (posn-window start))
	 (frame (window-frame window))
377 378 379 380 381 382 383 384 385 386 387
	 ;; `position' records the x- or y-coordinate of the last
	 ;; sampled position.
	 (position (if (eq line 'vertical)
		       (+ (window-pixel-left window)
			  (car (posn-x-y start)))
		     (+ (window-pixel-top window)
			(cdr (posn-x-y start)))))
	 ;; `last-position' records the x- or y-coordinate of the
	 ;; previously sampled position.  The difference of `position'
	 ;; and `last-position' determines the size change of WINDOW.
	 (last-position position)
388
	 (draggable t)
389 390 391
	 posn-window growth dragged)
    ;; Decide on whether we are allowed to track at all and whose
    ;; window's edge we drag.
392 393
    (cond
     ((eq line 'header)
394
      (if (window-at-side-p window 'top)
395
	  ;; We can't drag the header line of a topmost window.
396
	  (setq draggable nil)
397
	;; Drag bottom edge of window above the header line.
398
	(setq window (window-in-direction 'above window t))))
399
     ((eq line 'mode)
400
      (if (and (window-at-side-p window 'bottom)
401 402 403 404 405 406 407 408
	       ;; Allow resizing the minibuffer window if it's on the
	       ;; same frame as and immediately below `window', and it's
	       ;; either active or `resize-mini-windows' is nil.
	       (let ((minibuffer-window (minibuffer-window frame)))
		 (not (and (eq (window-frame minibuffer-window) frame)
			   (or (not resize-mini-windows)
			       (eq minibuffer-window
				   (active-minibuffer-window)))))))
409 410 411 412 413 414 415 416 417
	  (setq draggable nil)))
     ((eq line 'vertical)
      (let ((divider-width (frame-right-divider-width frame)))
        (when (and (or (not (numberp divider-width))
                       (zerop divider-width))
                   (eq (cdr (assq 'vertical-scroll-bars
                                  (frame-parameters frame)))
                       'left))
	(setq window (window-in-direction 'left window t))))))
418

419 420
    (let* ((exitfun nil)
           (move
421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469
	    (lambda (event) (interactive "e")
	      (cond
	       ((not (consp event))
		nil)
	       ((eq line 'vertical)
		;; Drag right edge of `window'.
		(setq start (event-start event))
		(setq position (car (posn-x-y start)))
		;; Set `posn-window' to the window where `event' was recorded.
		;; This can be `window' or the window on the left or right of
		;; `window'.
		(when (window-live-p (setq posn-window (posn-window start)))
		  ;; Add left edge of `posn-window' to `position'.
		  (setq position (+ (window-pixel-left posn-window) position))
		  (unless (nth 1 start)
		    ;; Add width of objects on the left of the text area to
		    ;; `position'.
		    (when (eq (window-current-scroll-bars posn-window) 'left)
		      (setq position (+ (window-scroll-bar-width posn-window)
					position)))
		    (setq position (+ (car (window-fringes posn-window))
				      (or (car (window-margins posn-window)) 0)
				      position))))
		;; When the cursor overshoots after shrinking a window to its
		;; minimum size and the dragging direction changes, have the
		;; cursor first catch up with the window edge.
		(unless (or (zerop (setq growth (- position last-position)))
			    (and (> growth 0)
				 (< position (+ (window-pixel-left window)
						(window-pixel-width window))))
			    (and (< growth 0)
				 (> position (+ (window-pixel-left window)
						(window-pixel-width window)))))
		  (setq dragged t)
		  (adjust-window-trailing-edge window growth t t))
		(setq last-position position))
	       (draggable
		;; Drag bottom edge of `window'.
		(setq start (event-start event))
		;; Set `posn-window' to the window where `event' was recorded.
		;; This can be either `window' or the window above or below of
		;; `window'.
		(setq posn-window (posn-window start))
		(setq position (cdr (posn-x-y start)))
		(when (window-live-p posn-window)
		  ;; Add top edge of `posn-window' to `position'.
		  (setq position (+ (window-pixel-top posn-window) position))
		  ;; If necessary, add height of header line to `position'
		  (when (memq (posn-area start)
470
			      '(nil left-fringe right-fringe left-margin right-margin))
471 472 473 474 475 476 477 478 479 480 481 482 483 484
		    (setq position (+ (window-header-line-height posn-window) position))))
		;; When the cursor overshoots after shrinking a window to its
		;; minimum size and the dragging direction changes, have the
		;; cursor first catch up with the window edge.
		(unless (or (zerop (setq growth (- position last-position)))
			    (and (> growth 0)
				 (< position (+ (window-pixel-top window)
						(window-pixel-height window))))
			    (and (< growth 0)
				 (> position (+ (window-pixel-top window)
						(window-pixel-height window)))))
		  (setq dragged t)
		  (adjust-window-trailing-edge window growth nil t))
		(setq last-position position))))))
485 486 487 488
      ;; Start tracking.  The special value 'dragging' signals the
      ;; display engine to freeze the mouse pointer shape for as long
      ;; as we drag.
      (setq track-mouse 'dragging)
489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507
      ;; Loop reading events and sampling the position of the mouse.
      (setq exitfun
	    (set-transient-map
	     (let ((map (make-sparse-keymap)))
	       (define-key map [switch-frame] #'ignore)
	       (define-key map [select-window] #'ignore)
	       (define-key map [scroll-bar-movement] #'ignore)
	       (define-key map [mouse-movement] move)
	       ;; Swallow drag-mouse-1 events to avoid selecting some other window.
	       (define-key map [drag-mouse-1]
		 (lambda () (interactive) (funcall exitfun)))
	       ;; For vertical line dragging swallow also a mouse-1
	       ;; event (but only if we dragged at least once to allow mouse-1
	       ;; clicks to get through).
	       (when (eq line 'vertical)
		 (define-key map [mouse-1]
		   `(menu-item "" ,(lambda () (interactive) (funcall exitfun))
			       :filter ,(lambda (cmd) (if dragged cmd)))))
	       ;; Some of the events will of course end up looked up
508
	       ;; with a mode-line, header-line or vertical-line prefix ...
509 510
	       (define-key map [mode-line] map)
	       (define-key map [header-line] map)
511
	       (define-key map [vertical-line] map)
512 513 514 515 516 517
	       ;; ... and some maybe even with a right- or bottom-divider
	       ;; prefix.
	       (define-key map [right-divider] map)
	       (define-key map [bottom-divider] map)
	       map)
	     t (lambda () (setq track-mouse nil)))))))
518

519 520 521
(defun mouse-drag-mode-line (start-event)
  "Change the height of a window by dragging on the mode line."
  (interactive "e")
522
  (mouse-drag-line start-event 'mode))
523 524

(defun mouse-drag-header-line (start-event)
525
  "Change the height of a window by dragging on the header line."
526
  (interactive "e")
527
  (mouse-drag-line start-event 'header))
528

529 530 531
(defun mouse-drag-vertical-line (start-event)
  "Change the width of a window by dragging on the vertical line."
  (interactive "e")
532
  (mouse-drag-line start-event 'vertical))
533

534
(defun mouse-set-point (event &optional promote-to-region)
Jim Blandy's avatar
Jim Blandy committed
535
  "Move point to the position clicked on with the mouse.
536 537 538 539
This should be bound to a mouse click event type.
If PROMOTE-TO-REGION is non-nil and event is a multiple-click,
select the corresponding element around point."
  (interactive "e\np")
540
  (mouse-minibuffer-check event)
541 542 543 544 545
  (if (and promote-to-region (> (event-click-count event) 1))
      (mouse-set-region event)
    ;; Use event-end in case called from mouse-drag-region.
    ;; If EVENT is a click, event-end and event-start give same value.
    (posn-set-point (event-end event))))
Jim Blandy's avatar
Jim Blandy committed
546

547 548 549 550 551 552 553 554 555 556 557
(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))))

558 559
(defvar mouse--drag-start-event nil)

560
(defun mouse-set-region (click)
561
  "Set the region to the text dragged over, and copy to kill ring.
562 563 564
This should be bound to a mouse drag event.
See the `mouse-drag-copy-region' variable to control whether this
command alters the kill ring or not."
565
  (interactive "e")
566
  (mouse-minibuffer-check click)
567 568
  (select-window (posn-window (event-start click)))
  (let ((beg (posn-point (event-start click)))
569 570 571 572
	(end (posn-point (event-end click)))
        (click-count (event-click-count click)))
    (let ((drag-start (terminal-parameter nil 'mouse-drag-start)))
      (when drag-start
573 574 575
        ;; Drag events don't come with a click count, sadly, so we hack
        ;; our way around this problem by remembering the start-event in
        ;; `mouse-drag-start' and fetching the click-count from there.
576 577 578
        (when (and (<= click-count 1)
                   (equal beg (posn-point (event-start drag-start))))
          (setq click-count (event-click-count drag-start)))
579 580 581 582 583 584 585
        ;; Occasionally we get spurious drag events where the user hasn't
        ;; dragged his mouse, but instead Emacs has dragged the text under the
        ;; user's mouse.  Try to recover those cases (bug#17562).
        (when (and (equal (posn-x-y (event-start click))
                          (posn-x-y (event-end click)))
                   (not (eq (car drag-start) 'mouse-movement)))
          (setq end beg))
586 587 588 589 590 591
        (setf (terminal-parameter nil 'mouse-drag-start) nil)))
    (when (and (integerp beg) (integerp end))
      (let ((range (mouse-start-end beg end (1- click-count))))
        (if (< end beg)
            (setq end (nth 0 range) beg (nth 1 range))
          (setq beg (nth 0 range) end (nth 1 range)))))
592 593 594 595 596 597 598 599
    (and mouse-drag-copy-region (integerp beg) (integerp end)
	 ;; Don't set this-command to `kill-region', so a following
	 ;; C-w won't double the text in the kill ring.  Ignore
	 ;; `last-command' so we don't append to a preceding kill.
	 (let (this-command last-command deactivate-mark)
	   (copy-region-as-kill beg end)))
    (if (numberp beg) (goto-char beg))
    ;; On a text terminal, bounce the cursor.
600
    (or transient-mark-mode
601
	(window-system)
602
	(sit-for 1))
603
    (push-mark)
604
    (set-mark (point))
605
    (if (numberp end) (goto-char end))
606 607 608
    (mouse-set-region-1)))

(defun mouse-set-region-1 ()
609
  ;; Set transient-mark-mode for a little while.
610
  (unless (eq (car-safe transient-mark-mode) 'only)
611 612 613 614
    (setq-local transient-mark-mode
                (cons 'only
                      (unless (eq transient-mark-mode 'lambda)
                        transient-mark-mode))))
615 616 617
  (setq mouse-last-region-beg (region-beginning))
  (setq mouse-last-region-end (region-end))
  (setq mouse-last-region-tick (buffer-modified-tick)))
618

Richard M. Stallman's avatar
Richard M. Stallman committed
619
(defcustom mouse-scroll-delay 0.25
Lute Kamstra's avatar
Lute Kamstra committed
620
  "The pause between scroll steps caused by mouse drags, in seconds.
621 622 623 624 625
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
626 627 628
Setting this to zero causes Emacs to scroll as fast as it can."
  :type 'number
  :group 'mouse)
629

Richard M. Stallman's avatar
Richard M. Stallman committed
630
(defcustom mouse-scroll-min-lines 1
Lute Kamstra's avatar
Lute Kamstra committed
631
  "The minimum number of lines scrolled by dragging mouse out of window.
632 633 634 635
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
636 637 638
of lines specified by this variable."
  :type 'integer
  :group 'mouse)
639

640 641
(defun mouse-scroll-subr (window jump &optional overlay start)
  "Scroll the window WINDOW, JUMP lines at a time, until new input arrives.
642 643 644
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."
645 646 647 648 649
  (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))))
650 651 652 653 654 655 656
  (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)
657 658 659 660 661 662 663
		       (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)))
664 665 666 667 668 669 670 671
		     (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))
672
		   (sit-for mouse-scroll-delay)))))
673 674
    (or (eq window (selected-window))
	(goto-char opoint))))
675

676
(defvar mouse-selection-click-count 0)
677

678 679
(defvar mouse-selection-click-count-buffer nil)

680
(defun mouse-drag-region (start-event)
681
  "Set the region to the text that the mouse is dragged over.
682 683
Highlight the drag area as you move the mouse.
This must be bound to a button-down mouse event.
684
In Transient Mark mode, the highlighting remains as long as the mark
685
remains active.  Otherwise, it remains until the next input event."
686
  (interactive "e")
687 688
  ;; Give temporary modes such as isearch a chance to turn off.
  (run-hooks 'mouse-leave-buffer-hook)
689
  (mouse-drag-track start-event))
690

691

692
(defun mouse-posn-property (pos property)
693 694
  "Look for a property at click position.
POS may be either a buffer position or a click position like
695
those returned from `event-start'.  If the click position is on
696 697 698 699 700
a string, the text property PROPERTY is examined.
If this is nil or the click is not on a string, then
the corresponding buffer position is searched for PROPERTY.
If PROPERTY is encountered in one of those places,
its value is returned."
701 702 703 704 705
  (if (consp pos)
      (let ((w (posn-window pos)) (pt (posn-point pos))
	    (str (posn-string pos)))
	(or (and str
		 (get-text-property (cdr str) property (car str)))
706 707 708 709 710
            ;; Mouse clicks in the fringe come with a position in
            ;; (nth 5).  This is useful but is not exactly where we clicked, so
            ;; don't look up that position's properties!
	    (and pt (not (memq (posn-area pos) '(left-fringe right-fringe
                                                 left-margin right-margin)))
711 712 713
		 (get-char-property pt property w))))
    (get-char-property pos property)))

714 715
(defun mouse-on-link-p (pos)
  "Return non-nil if POS is on a link in the current buffer.
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
716 717
POS must be a buffer position in the current buffer or a mouse
event location in the selected window (see `event-start').
718 719
However, if `mouse-1-click-in-non-selected-windows' is non-nil,
POS may be a mouse event location in any window.
720 721 722

A clickable link is identified by one of the following methods:

Kim F. Storm's avatar
Kim F. Storm committed
723
- If the character at POS has a non-nil `follow-link' text or
724
overlay property, the value of that property determines what to do.
725

Kim F. Storm's avatar
Kim F. Storm committed
726 727 728
- If there is a local key-binding or a keybinding at position POS
for the `follow-link' event, the binding of that event determines
what to do.
729

Kim F. Storm's avatar
Kim F. Storm committed
730 731 732
The resulting value determine whether POS is inside a link:

- If the value is `mouse-face', POS is inside a link if there
733 734
is a non-nil `mouse-face' property at POS.  Return t in this case.

Kim F. Storm's avatar
Kim F. Storm committed
735
- If the value is a function, FUNC, POS is inside a link if
736
the call \(FUNC POS) returns non-nil.  Return the return value
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
737
from that call.  Arg is \(posn-point POS) if POS is a mouse event.
738

Kim F. Storm's avatar
Kim F. Storm committed
739
- Otherwise, return the value itself.
740 741 742 743 744 745 746 747 748 749 750 751 752

The return value is interpreted as follows:

- If it is a string, the mouse-1 event is translated into the
first character of the string, i.e. the action of the mouse-1
click is the local or global binding of that character.

- If it is a vector, the mouse-1 event is translated into the
first element of that vector, i.e. the action of the mouse-1
click is the local or global binding of that event.

- Otherwise, the mouse-1 event is translated into a mouse-2 event
at the same position."
753
  (let ((action
754
	 (and (or (not (consp pos))
755 756 757
		  mouse-1-click-in-non-selected-windows
		  (eq (selected-window) (posn-window pos)))
	      (or (mouse-posn-property pos 'follow-link)
758 759 760
                  (let ((area (posn-area pos)))
                    (when area
                      (key-binding (vector area 'follow-link) nil t pos)))
761 762 763 764 765
		  (key-binding [follow-link] nil t pos)))))
    (cond
     ((eq action 'mouse-face)
      (and (mouse-posn-property pos 'mouse-face) t))
     ((functionp action)
766
      ;; FIXME: This seems questionable if the click is not in a buffer.
767
      ;; Should we instead decide that `action' takes a `posn'?
768 769
      (if (consp pos)
	  (with-current-buffer (window-buffer (posn-window pos))
770
	    (funcall action (posn-point pos)))
771
	(funcall action pos)))
772
     (t action))))
773

774 775 776 777 778
(defun mouse-fixup-help-message (msg)
  "Fix help message MSG for `mouse-1-click-follows-link'."
  (let (mp pos)
    (if (and mouse-1-click-follows-link
	     (stringp msg)
779
	     (string-match-p "\\`mouse-2" msg)
780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795
	     (setq mp (mouse-pixel-position))
	     (consp (setq pos (cdr mp)))
	     (car pos) (>= (car pos) 0)
	     (cdr pos) (>= (cdr pos) 0)
	     (setq pos (posn-at-x-y (car pos) (cdr pos) (car mp)))
	     (windowp (posn-window pos)))
	(with-current-buffer (window-buffer (posn-window pos))
	  (if (mouse-on-link-p pos)
	      (setq msg (concat
		    (cond
		     ((eq mouse-1-click-follows-link 'double) "double-")
		     ((and (integerp mouse-1-click-follows-link)
			   (< mouse-1-click-follows-link 0)) "Long ")
		     (t ""))
		    "mouse-1" (substring msg 7)))))))
  msg)
796

797
(defun mouse-drag-track (start-event)
798
    "Track mouse drags by highlighting area between point and cursor.
799
The region will be defined with mark and point."
800
  (mouse-minibuffer-check start-event)
801
  (setq mouse-selection-click-count-buffer (current-buffer))
802
  (deactivate-mark)
803
  (let* ((scroll-margin 0) ; Avoid margin scrolling (Bug#9541).
804 805 806 807 808
         ;; We've recorded what we needed from the current buffer and
         ;; window, now let's jump to the place of the event, where things
         ;; are happening.
         (_ (mouse-set-point start-event))
         (echo-keystrokes 0)
809
	 (start-posn (event-start start-event))
810 811 812
	 (start-point (posn-point start-posn))
	 (start-window (posn-window start-posn))
	 (bounds (window-edges start-window))
813
	 (make-cursor-line-fully-visible nil)
814 815 816 817
	 (top (nth 1 bounds))
	 (bottom (if (window-minibuffer-p start-window)
		     (nth 3 bounds)
		   ;; Don't count the mode line.
818
		   (1- (nth 3 bounds))))
819
	 (click-count (1- (event-click-count start-event)))
820 821
	 ;; Suppress automatic hscrolling, because that is a nuisance
	 ;; when setting point near the right fringe (but see below).
822
	 (auto-hscroll-mode-saved auto-hscroll-mode))
823

824
    (setq mouse-selection-click-count click-count)
825 826 827 828 829
    ;; 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))
830

831 832
    ;; Activate the region, using `mouse-start-end' to determine where
    ;; to put point and mark (e.g., double-click will select a word).
833 834 835 836
    (setq-local transient-mark-mode
                (if (eq transient-mark-mode 'lambda)
                    '(only)
                  (cons 'only transient-mark-mode)))
837
    (let ((range (mouse-start-end start-point start-point click-count)))
838
      (push-mark (nth 0 range) t t)
839
      (goto-char (nth 1 range)))
840

841 842 843 844 845 846 847 848 849 850 851 852
    (setf (terminal-parameter nil 'mouse-drag-start) start-event)
    (setq track-mouse t)
    (setq auto-hscroll-mode nil)

    (set-transient-map
     (let ((map (make-sparse-keymap)))
       (define-key map [switch-frame] #'ignore)
       (define-key map [select-window] #'ignore)
       (define-key map [mouse-movement]
         (lambda (event) (interactive "e")
           (let* ((end (event-end event))
                  (end-point (posn-point end)))
853
             (unless (eq end-point start-point)
854
               ;; As soon as the user moves, we can re-enable auto-hscroll.
855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871
               (setq auto-hscroll-mode auto-hscroll-mode-saved)
               ;; And remember that we have moved, so mouse-set-region can know
               ;; its event is really a drag event.
               (setcar start-event 'mouse-movement))
             (if (and (eq (posn-window end) start-window)
                      (integer-or-marker-p end-point))
                 (mouse--drag-set-mark-and-point start-point
                                                 end-point click-count)
               (let ((mouse-row (cdr (cdr (mouse-position)))))
                 (cond
                  ((null mouse-row))
                  ((< mouse-row top)
                   (mouse-scroll-subr start-window (- mouse-row top)
                                      nil start-point))
                  ((>= mouse-row bottom)
                   (mouse-scroll-subr start-window (1+ (- mouse-row bottom))
                                      nil start-point))))))))
872 873 874 875
       map)
     t (lambda ()
         (setq track-mouse nil)
         (setq auto-hscroll-mode auto-hscroll-mode-saved)
876
          (deactivate-mark)
877
         (pop-mark)))))
878

879 880 881 882 883 884 885 886 887 888 889 890 891 892 893
(defun mouse--drag-set-mark-and-point (start click click-count)
  (let* ((range (mouse-start-end start click click-count))
	 (beg (nth 0 range))
	 (end (nth 1 range)))
    (cond ((eq (mark) beg)
	   (goto-char end))
	  ((eq (mark) end)
	   (goto-char beg))
	  ((< click (mark))
	   (set-mark end)
	   (goto-char beg))
	  (t
	   (set-mark beg)
	   (goto-char end)))))

894 895 896 897 898 899
;; Commands to handle xterm-style multiple clicks.
(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))))
900 901 902 903
    (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,
Glenn Morris's avatar
Glenn Morris committed
904
	   ;; we simulate the original behavior by using forward-word.
905 906 907 908 909 910
	   (if (< dir 0)
	       (if (not (looking-at "\\<"))
		   (forward-word -1))
	     (if (or (looking-at "\\<") (not (looking-at "\\>")))
		 (forward-word 1))))
	  ((string= syntax " ")
911 912 913 914 915 916 917 918 919 920 921 922 923
	   (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))))))
924

925
(defun mouse-start-end (start end mode)
926
  "Return a list of region bounds based on START and END according to MODE.
927 928 929 930
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."
931 932 933 934
  (if (> start end)
      (let ((temp start))
        (setq start end
              end temp)))
935
  (setq mode (mod mode 3))
936 937 938 939
  (cond ((= mode 0)
	 (list start end))
        ((and (= mode 1)
              (= start end)
940
	      (char-after start)