1 ;;; mouse.el --- window system-independent mouse support -*- lexical-binding: t -*-
3 ;; Copyright (C) 1993-1995, 1999-2018 Free Software Foundation, Inc.
5 ;; Maintainer: emacs-devel@gnu.org
6 ;; Keywords: hardware, mouse
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
26 ;; This package provides various useful commands (including help
27 ;; system access) through the mouse. All this code assumes that mouse
28 ;; interpretation has been abstracted into Emacs input events.
32 ;;; Utility functions.
34 ;; Indent track-mouse like progn.
35 (put 'track-mouse
'lisp-indent-function
0)
38 "Input from the mouse." ;; "Mouse support."
42 (defcustom mouse-yank-at-point nil
43 "If non-nil, mouse yank commands yank at point instead of at click."
46 (defcustom mouse-drag-copy-region nil
47 "If non-nil, copy to kill-ring upon mouse adjustments of the region.
49 This affects `mouse-save-then-kill' (\\[mouse-save-then-kill]) in
50 addition to mouse drags."
54 (defcustom mouse-1-click-follows-link
450
55 "Non-nil means that clicking Mouse-1 on a link follows the link.
57 With the default setting, an ordinary Mouse-1 click on a link
58 performs the same action as Mouse-2 on that link, while a longer
59 Mouse-1 click (hold down the Mouse-1 button for more than 450
60 milliseconds) performs the original Mouse-1 binding (which
61 typically sets point where you click the mouse).
63 If value is an integer, the time elapsed between pressing and
64 releasing the mouse button determines whether to follow the link
65 or perform the normal Mouse-1 action (typically set point).
66 The absolute numeric value specifies the maximum duration of a
67 \"short click\" in milliseconds. A positive value means that a
68 short click follows the link, and a longer click performs the
69 normal action. A negative value gives the opposite behavior.
71 If value is `double', a double click follows the link.
73 Otherwise, a single Mouse-1 click unconditionally follows the link.
75 Note that dragging the mouse never follows the link.
77 This feature only works in modes that specifically identify
78 clickable text as links, so it may not work with some external
79 packages. See `mouse-on-link-p' for details."
81 :type
'(choice (const :tag
"Disabled" nil
)
82 (const :tag
"Double click" double
)
83 (number :tag
"Single click time limit" :value
450)
84 (other :tag
"Single click" t
)))
86 (defcustom mouse-1-click-in-non-selected-windows t
87 "If non-nil, a Mouse-1 click also follows links in non-selected windows.
89 If nil, a Mouse-1 click on a link in a non-selected window performs
90 the normal mouse-1 binding, typically selects the window and sets
91 point at the click position."
95 (defvar mouse--last-down nil
)
97 (defun mouse--down-1-maybe-follows-link (&optional _prompt
)
98 (when mouse-1-click-follows-link
99 (setq mouse--last-down
(cons (car-safe last-input-event
) (float-time))))
102 (defun mouse--click-1-maybe-follows-link (&optional _prompt
)
103 "Turn `mouse-1' events into `mouse-2' events if follows-link.
104 Expects to be bound to `(double-)mouse-1' in `key-translation-map'."
105 (and mouse--last-down
106 (pcase mouse-1-click-follows-link
108 ('double
(eq 'double-mouse-1
(car-safe last-input-event
)))
109 (_ (and (eq 'mouse-1
(car-safe last-input-event
))
110 (or (not (numberp mouse-1-click-follows-link
))
111 (funcall (if (< mouse-1-click-follows-link
0) #'> #'<)
112 (- (float-time) (cdr mouse--last-down
))
113 (/ (abs mouse-1-click-follows-link
) 1000.0))))))
114 (eq (car mouse--last-down
)
115 (event-convert-list (list 'down
(car-safe last-input-event
))))
116 (let* ((action (mouse-on-link-p (event-start last-input-event
))))
118 (or mouse-1-click-in-non-selected-windows
119 (eq (selected-window)
120 (posn-window (event-start last-input-event
)))))
121 ;; Turn the mouse-1 into a mouse-2 to follow links,
122 ;; but only if ‘mouse-on-link-p’ hasn’t returned a
123 ;; string or vector (see its docstring).
125 (vector (aref action
0))
126 (let ((newup (if (eq mouse-1-click-follows-link
'double
)
127 'double-mouse-2
'mouse-2
)))
128 ;; If mouse-2 has never been done by the user, it
129 ;; doesn't have the necessary property to be
130 ;; interpreted correctly.
131 (unless (get newup
'event-kind
)
132 (put newup
'event-kind
133 (get (car last-input-event
) 'event-kind
)))
134 ;; Modify the event in-place, otherwise we can get a prefix
135 ;; added again, so a click on the header-line turns
136 ;; into a [header-line header-line mouse-2] :-(.
137 ;; See fake_prefixed_keys in src/keyboard.c's.
138 (setf (car last-input-event
) newup
)
139 (vector last-input-event
)))))))
141 (define-key key-translation-map
[down-mouse-1
]
142 #'mouse--down-1-maybe-follows-link
)
143 (define-key key-translation-map
[double-down-mouse-1
]
144 #'mouse--down-1-maybe-follows-link
)
145 (define-key key-translation-map
[mouse-1
]
146 #'mouse--click-1-maybe-follows-link
)
147 (define-key key-translation-map
[double-mouse-1
]
148 #'mouse--click-1-maybe-follows-link
)
151 ;; Provide a mode-specific menu on a mouse button.
153 (defun minor-mode-menu-from-indicator (indicator)
154 "Show menu for minor mode specified by INDICATOR.
155 Interactively, INDICATOR is read using completion.
156 If there is no menu defined for the minor mode, then create one with
157 items `Turn Off' and `Help'."
159 (list (completing-read
160 "Minor mode indicator: "
161 (describe-minor-mode-completion-table-for-indicator))))
162 (let* ((minor-mode (lookup-minor-mode-from-indicator indicator
))
163 (mm-fun (or (get minor-mode
:minor-mode-function
) minor-mode
)))
164 (unless minor-mode
(error "Cannot find minor mode for `%s'" indicator
))
165 (let* ((map (cdr-safe (assq minor-mode minor-mode-map-alist
)))
166 (menu (and (keymapp map
) (lookup-key map
[menu-bar
]))))
169 (mouse-menu-non-singleton menu
)
170 (if (fboundp mm-fun
) ; bug#20201
173 (turn-off menu-item
"Turn off minor mode" ,mm-fun
)
174 (help menu-item
"Help for minor mode"
175 (lambda () (interactive)
176 (describe-function ',mm-fun
)))))))
179 (message "No menu available")))))
181 (defun mouse-minor-mode-menu (event)
182 "Show minor-mode menu for EVENT on minor modes area of the mode line."
184 (let ((indicator (car (nth 4 (car (cdr event
))))))
185 (minor-mode-menu-from-indicator indicator
)))
187 (defun mouse-menu-major-mode-map ()
188 (run-hooks 'activate-menubar-hook
'menu-bar-update-hook
)
189 (let* (;; Keymap from which to inherit; may be null.
190 (ancestor (mouse-menu-non-singleton
191 (and (current-local-map)
192 (local-key-binding [menu-bar
]))))
193 ;; Make a keymap in which our last command leads to a menu or
194 ;; default to the edit menu.
196 (make-sparse-keymap (concat (format-mode-line mode-name
)
198 menu-bar-edit-menu
)))
200 (set-keymap-parent newmap ancestor
))
203 (defun mouse-menu-non-singleton (menubar)
204 "Return menu keybar MENUBAR, or a lone submenu inside it.
205 If MENUBAR defines exactly one submenu, return just that submenu.
206 Otherwise, return MENUBAR."
210 (lambda (k v
) (setq submap
(if submap t
(cons k v
))))
211 (keymap-canonicalize menubar
))
214 (lookup-key menubar
(vector (car submap
)))))))
216 (defun mouse-menu-bar-map ()
217 "Return a keymap equivalent to the menu bar.
218 The contents are the items that would be in the menu bar whether or
219 not it is actually displayed."
220 (run-hooks 'activate-menubar-hook
'menu-bar-update-hook
)
221 (let* ((local-menu (and (current-local-map)
222 (lookup-key (current-local-map) [menu-bar
])))
223 (global-menu (lookup-key global-map
[menu-bar
]))
224 ;; If a keymap doesn't have a prompt string (a lazy
225 ;; programmer didn't bother to provide one), create it and
226 ;; insert it into the keymap; each keymap gets its own
227 ;; prompt. This is required for non-toolkit versions to
228 ;; display non-empty menu pane names.
232 (let* ((minor-mode (car menu
))
234 (title-or-map (cadr menu
)))
235 (or (stringp title-or-map
)
239 (capitalize (subst-char-in-string
245 (minor-mode-key-binding [menu-bar
])))
246 (local-title-or-map (and local-menu
(cadr local-menu
)))
247 (global-title-or-map (cadr global-menu
)))
248 (or (null local-menu
)
249 (stringp local-title-or-map
)
250 (setq local-menu
(cons 'keymap
251 (cons (concat (format-mode-line mode-name
)
254 (or (stringp global-title-or-map
)
255 (setq global-menu
(cons 'keymap
257 (cdr global-menu
)))))
258 ;; Supplying the list is faster than making a new map.
259 ;; FIXME: We have a problem here: we have to use the global/local/minor
260 ;; so they're displayed in the expected order, but later on in the command
261 ;; loop, they're actually looked up in the opposite order.
267 (defun mouse-major-mode-menu (event &optional prefix
)
268 "Pop up a mode-specific menu of mouse commands.
269 Default to the Edit menu if the major mode doesn't define a menu."
270 (declare (obsolete mouse-menu-major-mode-map
"23.1"))
271 (interactive "@e\nP")
272 (run-hooks 'activate-menubar-hook
'menu-bar-update-hook
)
273 (popup-menu (mouse-menu-major-mode-map) event prefix
))
275 (defun mouse-popup-menubar (event prefix
)
276 "Pop up a menu equivalent to the menu bar for keyboard EVENT with PREFIX.
277 The contents are the items that would be in the menu bar whether or
278 not it is actually displayed."
279 (declare (obsolete mouse-menu-bar-map
"23.1"))
280 (interactive "@e \nP")
281 (run-hooks 'activate-menubar-hook
'menu-bar-update-hook
)
282 (popup-menu (mouse-menu-bar-map) (unless (integerp event
) event
) prefix
))
284 (defun mouse-popup-menubar-stuff (event prefix
)
285 "Popup a menu like either `mouse-major-mode-menu' or `mouse-popup-menubar'.
286 Use the former if the menu bar is showing, otherwise the latter."
287 (declare (obsolete nil
"23.1"))
288 (interactive "@e\nP")
289 (run-hooks 'activate-menubar-hook
'menu-bar-update-hook
)
291 (if (zerop (or (frame-parameter nil
'menu-bar-lines
) 0))
293 (mouse-menu-major-mode-map))
296 ;; Commands that operate on windows.
298 (defun mouse-minibuffer-check (event)
299 (let ((w (posn-window (event-start event
))))
300 (and (window-minibuffer-p w
)
301 (not (minibuffer-window-active-p w
))
302 (user-error "Minibuffer window is not active")))
303 ;; Give temporary modes such as isearch a chance to turn off.
304 (run-hooks 'mouse-leave-buffer-hook
))
306 (defun mouse-delete-window (click)
307 "Delete the window you click on.
308 Do nothing if the frame has just one window.
309 This command must be bound to a mouse click."
311 (unless (one-window-p t
)
312 (mouse-minibuffer-check click
)
313 (delete-window (posn-window (event-start click
)))))
315 (defun mouse-select-window (click)
316 "Select the window clicked on; don't move point."
318 (mouse-minibuffer-check click
)
319 (let ((oframe (selected-frame))
320 (frame (window-frame (posn-window (event-start click
)))))
321 (select-window (posn-window (event-start click
)))
324 (or (eq frame oframe
)
325 (set-mouse-position (selected-frame) (1- (frame-width)) 0))))
327 (define-obsolete-function-alias 'mouse-tear-off-window
'tear-off-window
"24.4")
328 (defun tear-off-window (click)
329 "Delete the selected window, and create a new frame displaying its buffer."
331 (mouse-minibuffer-check click
)
332 (let* ((window (posn-window (event-start click
)))
333 (buf (window-buffer window
))
334 (frame (make-frame))) ;FIXME: Use pop-to-buffer.
336 (switch-to-buffer buf
)
337 (delete-window window
)))
339 (defun mouse-delete-other-windows ()
340 "Delete all windows except the one you click on."
342 (delete-other-windows))
344 (defun mouse-split-window-vertically (click)
345 "Select Emacs window mouse is on, then split it vertically in half.
346 The window is split at the line clicked on.
347 This command must be bound to a mouse click."
349 (mouse-minibuffer-check click
)
350 (let ((start (event-start click
)))
351 (select-window (posn-window start
))
352 (let ((new-height (1+ (cdr (posn-col-row (event-end click
)))))
353 (first-line window-min-height
)
354 (last-line (- (window-height) window-min-height
)))
355 (if (< last-line first-line
)
356 (user-error "Window too short to split")
357 ;; Bind `window-combination-resize' to nil so we are sure to get
358 ;; the split right at the line clicked on.
359 (let (window-combination-resize)
360 (split-window-vertically
361 (min (max new-height first-line
) last-line
)))))))
363 (defun mouse-split-window-horizontally (click)
364 "Select Emacs window mouse is on, then split it horizontally in half.
365 The window is split at the column clicked on.
366 This command must be bound to a mouse click."
368 (mouse-minibuffer-check click
)
369 (let ((start (event-start click
)))
370 (select-window (posn-window start
))
371 (let ((new-width (1+ (car (posn-col-row (event-end click
)))))
372 (first-col window-min-width
)
373 (last-col (- (window-width) window-min-width
)))
374 (if (< last-col first-col
)
375 (user-error "Window too narrow to split")
376 ;; Bind `window-combination-resize' to nil so we are sure to get
377 ;; the split right at the column clicked on.
378 (let (window-combination-resize)
379 (split-window-horizontally
380 (min (max new-width first-col
) last-col
)))))))
382 (defun mouse-drag-line (start-event line
)
383 "Drag a mode line, header line, or vertical line with the mouse.
384 START-EVENT is the starting mouse event of the drag action. LINE
385 must be one of the symbols `header', `mode', or `vertical'."
386 ;; Give temporary modes such as isearch a chance to turn off.
387 (run-hooks 'mouse-leave-buffer-hook
)
388 (let* ((echo-keystrokes 0)
389 (start (event-start start-event
))
390 (window (posn-window start
))
391 (frame (window-frame window
))
392 ;; `position' records the x- or y-coordinate of the last
394 (position (if (eq line
'vertical
)
395 (+ (window-pixel-left window
)
396 (car (posn-x-y start
)))
397 (+ (window-pixel-top window
)
398 (cdr (posn-x-y start
)))))
399 ;; `last-position' records the x- or y-coordinate of the
400 ;; previously sampled position. The difference of `position'
401 ;; and `last-position' determines the size change of WINDOW.
402 (last-position position
)
404 posn-window growth dragged
)
405 ;; Decide on whether we are allowed to track at all and whose
406 ;; window's edge we drag.
409 ;; Drag bottom edge of window above the header line.
410 (setq window
(window-in-direction 'above window t
)))
413 (let ((divider-width (frame-right-divider-width frame
)))
414 (when (and (or (not (numberp divider-width
))
415 (zerop divider-width
))
416 (eq (frame-parameter frame
'vertical-scroll-bars
) 'left
))
417 (setq window
(window-in-direction 'left window t
))))))
420 (lambda (event) (interactive "e")
425 ;; Drag right edge of `window'.
426 (setq start
(event-start event
))
427 (setq position
(car (posn-x-y start
)))
428 ;; Set `posn-window' to the window where `event' was recorded.
429 ;; This can be `window' or the window on the left or right of
431 (when (window-live-p (setq posn-window
(posn-window start
)))
432 ;; Add left edge of `posn-window' to `position'.
433 (setq position
(+ (window-pixel-left posn-window
) position
))
434 (unless (nth 1 start
)
435 ;; Add width of objects on the left of the text area to
437 (when (eq (window-current-scroll-bars posn-window
) 'left
)
438 (setq position
(+ (window-scroll-bar-width posn-window
)
440 (setq position
(+ (car (window-fringes posn-window
))
441 (or (car (window-margins posn-window
)) 0)
443 ;; When the cursor overshoots after shrinking a window to its
444 ;; minimum size and the dragging direction changes, have the
445 ;; cursor first catch up with the window edge.
446 (unless (or (zerop (setq growth
(- position last-position
)))
448 (< position
(+ (window-pixel-left window
)
449 (window-pixel-width window
))))
451 (> position
(+ (window-pixel-left window
)
452 (window-pixel-width window
)))))
454 (adjust-window-trailing-edge window growth t t
))
455 (setq last-position position
))
457 ;; Drag bottom edge of `window'.
458 (setq start
(event-start event
))
459 ;; Set `posn-window' to the window where `event' was recorded.
460 ;; This can be either `window' or the window above or below of
462 (setq posn-window
(posn-window start
))
463 (setq position
(cdr (posn-x-y start
)))
464 (when (window-live-p posn-window
)
465 ;; Add top edge of `posn-window' to `position'.
466 (setq position
(+ (window-pixel-top posn-window
) position
))
467 ;; If necessary, add height of header line to `position'
468 (when (memq (posn-area start
)
469 '(nil left-fringe right-fringe left-margin right-margin
))
470 (setq position
(+ (window-header-line-height posn-window
) position
))))
471 ;; When the cursor overshoots after shrinking a window to its
472 ;; minimum size and the dragging direction changes, have the
473 ;; cursor first catch up with the window edge.
474 (unless (or (zerop (setq growth
(- position last-position
)))
476 (< position
(+ (window-pixel-top window
)
477 (window-pixel-height window
))))
479 (> position
(+ (window-pixel-top window
)
480 (window-pixel-height window
)))))
482 (adjust-window-trailing-edge window growth nil t
))
483 (setq last-position position
)))))
484 (old-track-mouse track-mouse
))
485 ;; Start tracking. The special value 'dragging' signals the
486 ;; display engine to freeze the mouse pointer shape for as long
488 (setq track-mouse
'dragging
)
489 ;; Loop reading events and sampling the position of the mouse.
492 (let ((map (make-sparse-keymap)))
493 (define-key map
[switch-frame
] #'ignore
)
494 (define-key map
[select-window
] #'ignore
)
495 (define-key map
[scroll-bar-movement
] #'ignore
)
496 (define-key map
[mouse-movement
] move
)
497 ;; Swallow drag-mouse-1 events to avoid selecting some other window.
498 (define-key map
[drag-mouse-1
]
499 (lambda () (interactive) (funcall exitfun
)))
500 ;; For vertical line dragging swallow also a mouse-1
501 ;; event (but only if we dragged at least once to allow mouse-1
502 ;; clicks to get through).
503 (when (eq line
'vertical
)
504 (define-key map
[mouse-1
]
505 `(menu-item "" ,(lambda () (interactive) (funcall exitfun
))
506 :filter
,(lambda (cmd) (if dragged cmd
)))))
507 ;; Some of the events will of course end up looked up
508 ;; with a mode-line, header-line or vertical-line prefix ...
509 (define-key map
[mode-line
] map
)
510 (define-key map
[header-line
] map
)
511 (define-key map
[vertical-line
] map
)
512 ;; ... and some maybe even with a right- or bottom-divider
514 (define-key map
[right-divider
] map
)
515 (define-key map
[bottom-divider
] map
)
517 t
(lambda () (setq track-mouse old-track-mouse
)))))))
519 (defun mouse-drag-mode-line (start-event)
520 "Change the height of a window by dragging on its mode line.
521 START-EVENT is the starting mouse event of the drag action.
523 If the drag happens in a mode line on the bottom of a frame and
524 that frame's `drag-with-mode-line' parameter is non-nil, drag the
527 (let* ((start (event-start start-event
))
528 (window (posn-window start
))
529 (frame (window-frame window
)))
531 ((not (window-live-p window
)))
532 ((or (not (window-at-side-p window
'bottom
))
533 ;; Allow resizing the minibuffer window if it's on the
534 ;; same frame as and immediately below `window', and it's
535 ;; either active or `resize-mini-windows' is nil.
536 (let ((minibuffer-window (minibuffer-window frame
)))
537 (and (eq (window-frame minibuffer-window
) frame
)
538 (or (not resize-mini-windows
)
539 (eq minibuffer-window
540 (active-minibuffer-window))))))
541 (mouse-drag-line start-event
'mode
))
542 ((and (frame-parameter frame
'drag-with-mode-line
)
543 (window-at-side-p window
'bottom
)
544 (let ((minibuffer-window (minibuffer-window frame
)))
545 (not (eq (window-frame minibuffer-window
) frame
))))
546 ;; Drag frame when the window is on the bottom of its frame and
547 ;; there is no minibuffer window below.
548 (mouse-drag-frame start-event
'move
)))))
550 (defun mouse-drag-header-line (start-event)
551 "Change the height of a window by dragging on its header line.
552 START-EVENT is the starting mouse event of the drag action.
554 If the drag happens in a header line on the top of a frame and
555 that frame's `drag-with-header-line' parameter is non-nil, drag
558 (let* ((start (event-start start-event
))
559 (window (posn-window start
)))
560 (if (and (window-live-p window
)
561 (not (window-at-side-p window
'top
)))
562 (mouse-drag-line start-event
'header
)
563 (let ((frame (window-frame window
)))
564 (when (frame-parameter frame
'drag-with-header-line
)
565 (mouse-drag-frame start-event
'move
))))))
567 (defun mouse-drag-vertical-line (start-event)
568 "Change the width of a window by dragging on a vertical line.
569 START-EVENT is the starting mouse event of the drag action."
571 (mouse-drag-line start-event
'vertical
))
573 (defun mouse-resize-frame (frame x-diff y-diff
&optional x-move y-move
)
574 "Helper function for `mouse-drag-frame'."
575 (let* ((frame-x-y (frame-position frame
))
576 (frame-x (car frame-x-y
))
577 (frame-y (cdr frame-x-y
))
581 (setq x-diff
(min x-diff frame-x
))
582 (setq x-move
(- frame-x x-diff
)))
583 (let* ((min-width (frame-windows-min-size frame t nil t
))
584 (min-diff (max 0 (- (frame-inner-width frame
) min-width
))))
585 (setq x-diff
(max x-diff
(- min-diff
)))
587 (setq x-move
(+ frame-x
(- x-diff
))))))
591 (setq y-diff
(min y-diff frame-y
))
592 (setq y-move
(- frame-y y-diff
)))
593 (let* ((min-height (frame-windows-min-size frame nil nil t
))
594 (min-diff (max 0 (- (frame-inner-height frame
) min-height
))))
595 (setq y-diff
(max y-diff
(- min-diff
)))
597 (setq y-move
(+ frame-y
(- y-diff
))))))
599 (unless (zerop x-diff
)
601 (push `(left .
,x-move
) alist
))
602 (push `(width .
(text-pixels .
,(+ (frame-text-width frame
) x-diff
)))
604 (unless (zerop y-diff
)
606 (push `(top .
,y-move
) alist
))
607 (push `(height .
(text-pixels .
,(+ (frame-text-height frame
) y-diff
)))
610 (modify-frame-parameters frame alist
))))
612 (defun mouse-drag-frame (start-event part
)
613 "Drag a frame or one of its edges with the mouse.
614 START-EVENT is the starting mouse event of the drag action. Its
615 position window denotes the frame that will be dragged.
617 PART specifies the part that has been dragged and must be one of
618 the symbols 'left', 'top', 'right', 'bottom', 'top-left',
619 'top-right', 'bottom-left', 'bottom-right' to drag an internal
620 border or edge. If PART equals 'move', this means to move the
621 frame with the mouse."
622 ;; Give temporary modes such as isearch a chance to turn off.
623 (run-hooks 'mouse-leave-buffer-hook
)
624 (let* ((echo-keystrokes 0)
625 (start (event-start start-event
))
626 (window (posn-window start
))
627 ;; FRAME is the frame to drag.
628 (frame (if (window-live-p window
)
629 (window-frame window
)
631 (width (frame-native-width frame
))
632 (height (frame-native-height frame
))
633 ;; PARENT is the parent frame of FRAME or, if FRAME is a
634 ;; top-level frame, FRAME's workarea.
635 (parent (frame-parent frame
))
638 `(0 0 ,(frame-native-width parent
) ,(frame-native-height parent
))
640 (car (display-monitor-attributes-list)))
641 (workarea (assq 'workarea attributes
)))
643 `(,(nth 1 workarea
) ,(nth 2 workarea
)
644 ,(+ (nth 1 workarea
) (nth 3 workarea
))
645 ,(+ (nth 2 workarea
) (nth 4 workarea
)))))))
646 (parent-left (and parent-edges
(nth 0 parent-edges
)))
647 (parent-top (and parent-edges
(nth 1 parent-edges
)))
648 (parent-right (and parent-edges
(nth 2 parent-edges
)))
649 (parent-bottom (and parent-edges
(nth 3 parent-edges
)))
650 ;; `pos-x' and `pos-y' record the x- and y-coordinates of the
651 ;; last sampled mouse position. Note that we sample absolute
652 ;; mouse positions to avoid that moving the mouse from one
653 ;; frame into another gets into our way. `last-x' and `last-y'
654 ;; records the x- and y-coordinates of the previously sampled
655 ;; position. The differences between `last-x' and `pos-x' as
656 ;; well as `last-y' and `pos-y' determine the amount the mouse
657 ;; has been dragged between the last two samples.
659 (last-x-y (mouse-absolute-pixel-position))
660 (last-x (car last-x-y
))
661 (last-y (cdr last-x-y
))
662 ;; `snap-x' and `snap-y' record the x- and y-coordinates of the
663 ;; mouse position when FRAME snapped. As soon as the
664 ;; difference between `pos-x' and `snap-x' (or `pos-y' and
665 ;; `snap-y') exceeds the value of FRAME's `snap-width'
666 ;; parameter, unsnap FRAME (at the respective side). `snap-x'
667 ;; and `snap-y' nil mean FRAME is currently not snapped.
674 (setq pos-x-y
(mouse-absolute-pixel-position))
675 (setq pos-x
(car pos-x-y
))
676 (setq pos-y
(cdr pos-x-y
))
679 (mouse-resize-frame frame
(- last-x pos-x
) 0 t
))
681 (mouse-resize-frame frame
0 (- last-y pos-y
) nil t
))
683 (mouse-resize-frame frame
(- pos-x last-x
) 0))
685 (mouse-resize-frame frame
0 (- pos-y last-y
)))
688 frame
(- last-x pos-x
) (- last-y pos-y
) t t
))
689 ((eq part
'top-right
)
691 frame
(- pos-x last-x
) (- last-y pos-y
) nil t
))
692 ((eq part
'bottom-left
)
694 frame
(- last-x pos-x
) (- pos-y last-y
) t
))
695 ((eq part
'bottom-right
)
697 frame
(- pos-x last-x
) (- pos-y last-y
)))
699 (let* ((old-position (frame-position frame
))
700 (old-left (car old-position
))
701 (old-top (cdr old-position
))
702 (left (+ old-left
(- pos-x last-x
)))
703 (top (+ old-top
(- pos-y last-y
)))
705 ;; `snap-width' (maybe also a yet to be provided
706 ;; `snap-height') could become floats to handle
707 ;; proportionality wrt PARENT. We don't do any
708 ;; checks on this parameter so far.
709 (snap-width (frame-parameter frame
'snap-width
)))
710 ;; Docking and constraining.
711 (when (and (numberp snap-width
) parent-edges
)
713 ;; Docking at the left parent edge.
716 ((and (> left parent-left
)
717 (<= (- left parent-left
) snap-width
))
718 ;; Snap when the mouse moved leftward and
719 ;; FRAME's left edge would end up within
720 ;; `snap-width' pixels from PARENT's left edge.
722 (setq left parent-left
))
723 ((and (<= left parent-left
)
724 (<= (- parent-left left
) snap-width
)
725 snap-x
(<= (- snap-x pos-x
) snap-width
))
726 ;; Stay snapped when the mouse moved leftward
727 ;; but not more than `snap-width' pixels from
728 ;; the time FRAME snapped.
729 (setq left parent-left
))
731 ;; Unsnap when the mouse moved more than
732 ;; `snap-width' pixels leftward from the time
736 (setq right
(+ left width
))
738 ((and (< right parent-right
)
739 (<= (- parent-right right
) snap-width
))
740 ;; Snap when the mouse moved rightward and
741 ;; FRAME's right edge would end up within
742 ;; `snap-width' pixels from PARENT's right edge.
744 (setq left
(- parent-right width
)))
745 ((and (>= right parent-right
)
746 (<= (- right parent-right
) snap-width
)
747 snap-x
(<= (- pos-x snap-x
) snap-width
))
748 ;; Stay snapped when the mouse moved rightward
749 ;; but not more more than `snap-width' pixels
750 ;; from the time FRAME snapped.
751 (setq left
(- parent-right width
)))
753 ;; Unsnap when the mouse moved rightward more
754 ;; than `snap-width' pixels from the time FRAME
756 (setq snap-x nil
)))))
761 ((and (> top parent-top
)
762 (<= (- top parent-top
) snap-width
))
763 ;; Snap when the mouse moved upward and FRAME's
764 ;; top edge would end up within `snap-width'
765 ;; pixels from PARENT's top edge.
767 (setq top parent-top
))
768 ((and (<= top parent-top
)
769 (<= (- parent-top top
) snap-width
)
770 snap-y
(<= (- snap-y pos-y
) snap-width
))
771 ;; Stay snapped when the mouse moved upward but
772 ;; not more more than `snap-width' pixels from
773 ;; the time FRAME snapped.
774 (setq top parent-top
))
776 ;; Unsnap when the mouse moved upward more than
777 ;; `snap-width' pixels from the time FRAME
781 (setq bottom
(+ top height
))
783 ((and (< bottom parent-bottom
)
784 (<= (- parent-bottom bottom
) snap-width
))
785 ;; Snap when the mouse moved downward and
786 ;; FRAME's bottom edge would end up within
787 ;; `snap-width' pixels from PARENT's bottom
790 (setq top
(- parent-bottom height
)))
791 ((and (>= bottom parent-bottom
)
792 (<= (- bottom parent-bottom
) snap-width
)
793 snap-y
(<= (- pos-y snap-y
) snap-width
))
794 ;; Stay snapped when the mouse moved downward
795 ;; but not more more than `snap-width' pixels
796 ;; from the time FRAME snapped.
797 (setq top
(- parent-bottom height
)))
799 ;; Unsnap when the mouse moved downward more
800 ;; than `snap-width' pixels from the time FRAME
802 (setq snap-y nil
))))))
804 ;; If requested, constrain FRAME's draggable areas to
805 ;; PARENT's edges. The `top-visible' parameter should
806 ;; be set when FRAME has a draggable header-line. If
807 ;; set to a number, it ascertains that the top of
808 ;; FRAME is always constrained to the top of PARENT
809 ;; and that at least as many pixels of FRAME as
810 ;; specified by that number are visible on each of the
811 ;; three remaining sides of PARENT.
813 ;; The `bottom-visible' parameter should be set when
814 ;; FRAME has a draggable mode-line. If set to a
815 ;; number, it ascertains that the bottom of FRAME is
816 ;; always constrained to the bottom of PARENT and that
817 ;; at least as many pixels of FRAME as specified by
818 ;; that number are visible on each of the three
819 ;; remaining sides of PARENT.
820 (let ((par (frame-parameter frame
'top-visible
))
823 (setq par
(frame-parameter frame
'bottom-visible
))
824 (setq bottom-visible t
))
825 (when (and (numberp par
) parent-edges
)
827 (max (min (- parent-right par
) left
)
828 (+ (- parent-left width
) par
)))
831 (min (max top
(- parent-top
(- height par
)))
832 (- parent-bottom height
))
833 (min (max top parent-top
)
834 (- parent-bottom par
))))))
836 ;; Use `modify-frame-parameters' since `left' and
837 ;; `top' may want to move FRAME out of its PARENT.
838 (modify-frame-parameters
840 `((left .
(+ ,left
)) (top .
(+ ,top
)))))))
842 (setq last-y pos-y
))))
843 (old-track-mouse track-mouse
))
844 ;; Start tracking. The special value 'dragging' signals the
845 ;; display engine to freeze the mouse pointer shape for as long
847 (setq track-mouse
'dragging
)
848 ;; Loop reading events and sampling the position of the mouse.
851 (let ((map (make-sparse-keymap)))
852 (define-key map
[switch-frame
] #'ignore
)
853 (define-key map
[select-window
] #'ignore
)
854 (define-key map
[scroll-bar-movement
] #'ignore
)
855 (define-key map
[mouse-movement
] move
)
856 ;; Swallow drag-mouse-1 events to avoid selecting some other window.
857 (define-key map
[drag-mouse-1
]
858 (lambda () (interactive) (funcall exitfun
)))
859 ;; Some of the events will of course end up looked up
860 ;; with a mode-line, header-line or vertical-line prefix ...
861 (define-key map
[mode-line
] map
)
862 (define-key map
[header-line
] map
)
863 (define-key map
[vertical-line
] map
)
864 ;; ... and some maybe even with a right- or bottom-divider
866 (define-key map
[right-divider
] map
)
867 (define-key map
[bottom-divider
] map
)
869 t
(lambda () (setq track-mouse old-track-mouse
))))))
871 (defun mouse-drag-left-edge (start-event)
872 "Drag left edge of a frame with the mouse.
873 START-EVENT is the starting mouse event of the drag action."
875 (mouse-drag-frame start-event
'left
))
877 (defun mouse-drag-top-left-corner (start-event)
878 "Drag top left corner of a frame with the mouse.
879 START-EVENT is the starting mouse event of the drag action."
881 (mouse-drag-frame start-event
'top-left
))
883 (defun mouse-drag-top-edge (start-event)
884 "Drag top edge of a frame with the mouse.
885 START-EVENT is the starting mouse event of the drag action."
887 (mouse-drag-frame start-event
'top
))
889 (defun mouse-drag-top-right-corner (start-event)
890 "Drag top right corner of a frame with the mouse.
891 START-EVENT is the starting mouse event of the drag action."
893 (mouse-drag-frame start-event
'top-right
))
895 (defun mouse-drag-right-edge (start-event)
896 "Drag right edge of a frame with the mouse.
897 START-EVENT is the starting mouse event of the drag action."
899 (mouse-drag-frame start-event
'right
))
901 (defun mouse-drag-bottom-right-corner (start-event)
902 "Drag bottom right corner of a frame with the mouse.
903 START-EVENT is the starting mouse event of the drag action."
905 (mouse-drag-frame start-event
'bottom-right
))
907 (defun mouse-drag-bottom-edge (start-event)
908 "Drag bottom edge of a frame with the mouse.
909 START-EVENT is the starting mouse event of the drag action."
911 (mouse-drag-frame start-event
'bottom
))
913 (defun mouse-drag-bottom-left-corner (start-event)
914 "Drag bottom left corner of a frame with the mouse.
915 START-EVENT is the starting mouse event of the drag action."
917 (mouse-drag-frame start-event
'bottom-left
))
919 (defcustom mouse-select-region-move-to-beginning nil
920 "Effect of selecting a region extending backward from double click.
921 Nil means keep point at the position clicked (region end);
922 non-nil means move point to beginning of region."
923 :type
'(choice (const :tag
"Don't move point" nil
)
924 (const :tag
"Move point to beginning of region" t
))
927 (defun mouse-set-point (event &optional promote-to-region
)
928 "Move point to the position clicked on with the mouse.
929 This should be bound to a mouse click event type.
930 If PROMOTE-TO-REGION is non-nil and event is a multiple-click, select
931 the corresponding element around point, with the resulting position of
932 point determined by `mouse-select-region-move-to-beginning'."
934 (mouse-minibuffer-check event
)
935 (if (and promote-to-region
(> (event-click-count event
) 1))
937 (mouse-set-region event
)
938 (when mouse-select-region-move-to-beginning
939 (when (> (posn-point (event-start event
)) (region-beginning))
940 (exchange-point-and-mark))))
941 ;; Use event-end in case called from mouse-drag-region.
942 ;; If EVENT is a click, event-end and event-start give same value.
943 (posn-set-point (event-end event
))))
945 (defvar mouse-last-region-beg nil
)
946 (defvar mouse-last-region-end nil
)
947 (defvar mouse-last-region-tick nil
)
949 (defun mouse-region-match ()
950 "Return non-nil if there's an active region that was set with the mouse."
951 (and (mark t
) mark-active
952 (eq mouse-last-region-beg
(region-beginning))
953 (eq mouse-last-region-end
(region-end))
954 (eq mouse-last-region-tick
(buffer-modified-tick))))
956 (defvar mouse--drag-start-event nil
)
958 (defun mouse-set-region (click)
959 "Set the region to the text dragged over, and copy to kill ring.
960 This should be bound to a mouse drag event.
961 See the `mouse-drag-copy-region' variable to control whether this
962 command alters the kill ring or not."
964 (mouse-minibuffer-check click
)
965 (select-window (posn-window (event-start click
)))
966 (let ((beg (posn-point (event-start click
)))
968 (if (eq (posn-window (event-end click
)) (selected-window))
969 (posn-point (event-end click
))
970 ;; If the mouse ends up in any other window or on the menu
971 ;; bar, use `window-point' of selected window (Bug#23707).
973 (click-count (event-click-count click
)))
974 (let ((drag-start (terminal-parameter nil
'mouse-drag-start
)))
976 ;; Drag events don't come with a click count, sadly, so we hack
977 ;; our way around this problem by remembering the start-event in
978 ;; `mouse-drag-start' and fetching the click-count from there.
979 (when (and (<= click-count
1)
980 (equal beg
(posn-point (event-start drag-start
))))
981 (setq click-count
(event-click-count drag-start
)))
982 ;; Occasionally we get spurious drag events where the user hasn't
983 ;; dragged his mouse, but instead Emacs has dragged the text under the
984 ;; user's mouse. Try to recover those cases (bug#17562).
985 (when (and (equal (posn-x-y (event-start click
))
986 (posn-x-y (event-end click
)))
987 (not (eq (car drag-start
) 'mouse-movement
)))
989 (setf (terminal-parameter nil
'mouse-drag-start
) nil
)))
990 (when (and (integerp beg
) (integerp end
))
991 (let ((range (mouse-start-end beg end
(1- click-count
))))
993 (setq end
(nth 0 range
) beg
(nth 1 range
))
994 (setq beg
(nth 0 range
) end
(nth 1 range
)))))
995 (and mouse-drag-copy-region
(integerp beg
) (integerp end
)
996 ;; Don't set this-command to `kill-region', so a following
997 ;; C-w won't double the text in the kill ring. Ignore
998 ;; `last-command' so we don't append to a preceding kill.
999 (let (this-command last-command deactivate-mark
)
1000 (copy-region-as-kill beg end
)))
1001 (if (numberp beg
) (goto-char beg
))
1002 ;; On a text terminal, bounce the cursor.
1003 (or transient-mark-mode
1008 (if (numberp end
) (goto-char end
))
1009 (mouse-set-region-1)))
1011 (defun mouse-set-region-1 ()
1012 ;; Set transient-mark-mode for a little while.
1013 (unless (eq (car-safe transient-mark-mode
) 'only
)
1014 (setq-local transient-mark-mode
1016 (unless (eq transient-mark-mode
'lambda
)
1017 transient-mark-mode
))))
1018 (setq mouse-last-region-beg
(region-beginning))
1019 (setq mouse-last-region-end
(region-end))
1020 (setq mouse-last-region-tick
(buffer-modified-tick)))
1022 (defcustom mouse-scroll-delay
0.25
1023 "The pause between scroll steps caused by mouse drags, in seconds.
1024 If you drag the mouse beyond the edge of a window, Emacs scrolls the
1025 window to bring the text beyond that edge into view, with a delay of
1026 this many seconds between scroll steps. Scrolling stops when you move
1027 the mouse back into the window, or release the button.
1028 This variable's value may be non-integral.
1029 Setting this to zero causes Emacs to scroll as fast as it can."
1032 (defcustom mouse-scroll-min-lines
1
1033 "The minimum number of lines scrolled by dragging mouse out of window.
1034 Moving the mouse out the top or bottom edge of the window begins
1035 scrolling repeatedly. The number of lines scrolled per repetition
1036 is normally equal to the number of lines beyond the window edge that
1037 the mouse has moved. However, it always scrolls at least the number
1038 of lines specified by this variable."
1041 (defun mouse-scroll-subr (window jump
&optional overlay start
)
1042 "Scroll the window WINDOW, JUMP lines at a time, until new input arrives.
1043 If OVERLAY is an overlay, let it stretch from START to the far edge of
1044 the newly visible text.
1045 Upon exit, point is at the far edge of the newly visible text."
1047 ((and (> jump
0) (< jump mouse-scroll-min-lines
))
1048 (setq jump mouse-scroll-min-lines
))
1049 ((and (< jump
0) (< (- jump
) mouse-scroll-min-lines
))
1050 (setq jump
(- mouse-scroll-min-lines
))))
1051 (let ((opoint (point)))
1053 (goto-char (window-start window
))
1054 (if (not (zerop (vertical-motion jump window
)))
1056 (set-window-start window
(point))
1058 (if (window-end window
)
1060 (goto-char (window-end window
))
1061 ;; window-end doesn't reflect the window's new
1062 ;; start position until the next redisplay.
1063 (vertical-motion (1- jump
) window
))
1064 (vertical-motion (- (window-height window
) 2)))
1065 (goto-char (window-start window
)))
1067 (move-overlay overlay start
(point)))
1068 ;; Now that we have scrolled WINDOW properly,
1069 ;; put point back where it was for the redisplay
1070 ;; so that we don't mess up the selected window.
1071 (or (eq window
(selected-window))
1073 (sit-for mouse-scroll-delay
)))))
1074 (or (eq window
(selected-window))
1075 (goto-char opoint
))))
1077 (defvar mouse-selection-click-count
0)
1079 (defvar mouse-selection-click-count-buffer nil
)
1081 (defun mouse-drag-region (start-event)
1082 "Set the region to the text that the mouse is dragged over.
1083 Highlight the drag area as you move the mouse.
1084 This must be bound to a button-down mouse event.
1085 In Transient Mark mode, the highlighting remains as long as the mark
1086 remains active. Otherwise, it remains until the next input event.
1088 When the region already exists and `mouse-drag-and-drop-region'
1089 is non-nil, this moves the entire region of text to where mouse
1090 is dragged over to."
1092 (if (and mouse-drag-and-drop-region
1093 (not (member 'triple
(event-modifiers start-event
)))
1094 (equal (mouse-posn-property (event-start start-event
) 'face
) 'region
))
1095 (mouse-drag-and-drop-region start-event
)
1096 ;; Give temporary modes such as isearch a chance to turn off.
1097 (run-hooks 'mouse-leave-buffer-hook
)
1098 (mouse-drag-track start-event
)))
1100 (defun mouse-posn-property (pos property
)
1101 "Look for a property at click position.
1102 POS may be either a buffer position or a click position like
1103 those returned from `event-start'. If the click position is on
1104 a string, the text property PROPERTY is examined.
1105 If this is nil or the click is not on a string, then
1106 the corresponding buffer position is searched for PROPERTY.
1107 If PROPERTY is encountered in one of those places,
1108 its value is returned."
1110 (let ((w (posn-window pos
)) (pt (posn-point pos
))
1111 (str (posn-string pos
)))
1113 (get-text-property (cdr str
) property
(car str
)))
1114 ;; Mouse clicks in the fringe come with a position in
1115 ;; (nth 5). This is useful but is not exactly where we clicked, so
1116 ;; don't look up that position's properties!
1117 (and pt
(not (memq (posn-area pos
) '(left-fringe right-fringe
1118 left-margin right-margin
)))
1119 (get-char-property pt property w
))))
1120 (get-char-property pos property
)))
1122 (defun mouse-on-link-p (pos)
1123 "Return non-nil if POS is on a link in the current buffer.
1124 POS must specify a buffer position in the current buffer, as a list
1125 of the form returned by the `event-start' and `event-end' functions,
1126 or a mouse event location in the selected window (see `event-start').
1127 However, if `mouse-1-click-in-non-selected-windows' is non-nil,
1128 POS may be a mouse event location in any window.
1130 A clickable link is identified by one of the following methods:
1132 - If the character at POS has a non-nil `follow-link' text or
1133 overlay property, the value of that property determines what to do.
1135 - If there is a local key-binding or a keybinding at position POS
1136 for the `follow-link' event, the binding of that event determines
1139 The resulting value determine whether POS is inside a link:
1141 - If the value is `mouse-face', POS is inside a link if there
1142 is a non-nil `mouse-face' property at POS. Return t in this case.
1144 - If the value is a function, FUNC, POS is inside a link if
1145 the call (FUNC POS) returns non-nil. Return the return value
1146 from that call. Arg is (posn-point POS) if POS is a mouse event.
1148 - Otherwise, return the value itself.
1150 The return value is interpreted as follows:
1152 - If it is an array, the mouse-1 event is translated into the
1153 first element of that array, i.e. the action of the mouse-1
1154 click is the local or global binding of that event.
1156 - Otherwise, the mouse-1 event is translated into a mouse-2 event
1157 at the same position."
1159 (and (or (not (consp pos
))
1160 mouse-1-click-in-non-selected-windows
1161 (eq (selected-window) (posn-window pos
)))
1162 (or (mouse-posn-property pos
'follow-link
)
1163 (let ((area (posn-area pos
)))
1165 (key-binding (vector area
'follow-link
) nil t pos
)))
1166 (key-binding [follow-link
] nil t pos
)))))
1168 ((eq action
'mouse-face
)
1169 (and (mouse-posn-property pos
'mouse-face
) t
))
1171 ;; FIXME: This seems questionable if the click is not in a buffer.
1172 ;; Should we instead decide that `action' takes a `posn'?
1174 (with-current-buffer (window-buffer (posn-window pos
))
1175 (funcall action
(posn-point pos
)))
1176 (funcall action pos
)))
1179 (defun mouse-fixup-help-message (msg)
1180 "Fix help message MSG for `mouse-1-click-follows-link'."
1182 (if (and mouse-1-click-follows-link
1184 (string-match-p "\\`mouse-2" msg
)
1185 (setq mp
(mouse-pixel-position))
1186 (consp (setq pos
(cdr mp
)))
1187 (car pos
) (>= (car pos
) 0)
1188 (cdr pos
) (>= (cdr pos
) 0)
1189 (setq pos
(posn-at-x-y (car pos
) (cdr pos
) (car mp
)))
1190 (windowp (posn-window pos
)))
1191 (with-current-buffer (window-buffer (posn-window pos
))
1192 (if (mouse-on-link-p pos
)
1195 ((eq mouse-1-click-follows-link
'double
) "double-")
1196 ((and (integerp mouse-1-click-follows-link
)
1197 (< mouse-1-click-follows-link
0)) "Long ")
1199 "mouse-1" (substring msg
7)))))))
1202 (defun mouse-drag-track (start-event)
1203 "Track mouse drags by highlighting area between point and cursor.
1204 The region will be defined with mark and point."
1205 (mouse-minibuffer-check start-event
)
1206 (setq mouse-selection-click-count-buffer
(current-buffer))
1208 (let* ((scroll-margin 0) ; Avoid margin scrolling (Bug#9541).
1209 (start-posn (event-start start-event
))
1210 (start-point (posn-point start-posn
))
1211 (start-window (posn-window start-posn
))
1212 (_ (with-current-buffer (window-buffer start-window
)
1213 (setq deactivate-mark nil
)))
1214 ;; We've recorded what we needed from the current buffer and
1215 ;; window, now let's jump to the place of the event, where things
1217 (_ (mouse-set-point start-event
))
1219 (bounds (window-edges start-window
))
1220 (make-cursor-line-fully-visible nil
)
1221 (top (nth 1 bounds
))
1222 (bottom (if (or (window-minibuffer-p start-window
)
1223 ;; Do not account for the mode line if there
1224 ;; is no mode line, which is common for child
1226 (not mode-line-format
))
1228 ;; Don't count the mode line.
1229 (1- (nth 3 bounds
))))
1230 (click-count (1- (event-click-count start-event
)))
1231 ;; Suppress automatic hscrolling, because that is a nuisance
1232 ;; when setting point near the right fringe (but see below).
1233 (auto-hscroll-mode-saved auto-hscroll-mode
)
1234 (old-track-mouse track-mouse
))
1236 (setq mouse-selection-click-count click-count
)
1237 ;; In case the down click is in the middle of some intangible text,
1238 ;; use the end of that text, and put it in START-POINT.
1239 (if (< (point) start-point
)
1240 (goto-char start-point
))
1241 (setq start-point
(point))
1243 ;; Activate the region, using `mouse-start-end' to determine where
1244 ;; to put point and mark (e.g., double-click will select a word).
1245 (setq-local transient-mark-mode
1246 (if (eq transient-mark-mode
'lambda
)
1248 (cons 'only transient-mark-mode
)))
1249 (let ((range (mouse-start-end start-point start-point click-count
)))
1250 (push-mark (nth 0 range
) t t
)
1251 (goto-char (nth 1 range
)))
1253 (setf (terminal-parameter nil
'mouse-drag-start
) start-event
)
1254 (setq track-mouse t
)
1255 (setq auto-hscroll-mode nil
)
1258 (let ((map (make-sparse-keymap)))
1259 (define-key map
[switch-frame
] #'ignore
)
1260 (define-key map
[select-window
] #'ignore
)
1261 (define-key map
[mouse-movement
]
1262 (lambda (event) (interactive "e")
1263 (let* ((end (event-end event
))
1264 (end-point (posn-point end
)))
1265 (unless (eq end-point start-point
)
1266 ;; As soon as the user moves, we can re-enable auto-hscroll.
1267 (setq auto-hscroll-mode auto-hscroll-mode-saved
)
1268 ;; And remember that we have moved, so mouse-set-region can know
1269 ;; its event is really a drag event.
1270 (setcar start-event
'mouse-movement
))
1271 (if (and (eq (posn-window end
) start-window
)
1272 (integer-or-marker-p end-point
))
1273 (mouse--drag-set-mark-and-point start-point
1274 end-point click-count
)
1275 (let ((mouse-row (cdr (cdr (mouse-position)))))
1279 (mouse-scroll-subr start-window
(- mouse-row top
)
1281 ((>= mouse-row bottom
)
1282 (mouse-scroll-subr start-window
(1+ (- mouse-row bottom
))
1283 nil start-point
))))))))
1286 (setq track-mouse old-track-mouse
)
1287 (setq auto-hscroll-mode auto-hscroll-mode-saved
)
1291 (defun mouse--drag-set-mark-and-point (start click click-count
)
1292 (let* ((range (mouse-start-end start click click-count
))
1294 (end (nth 1 range
)))
1295 (cond ((eq (mark) beg
)
1306 ;; Commands to handle xterm-style multiple clicks.
1307 (defun mouse-skip-word (dir)
1308 "Skip over word, over whitespace, or over identical punctuation.
1309 If DIR is positive skip forward; if negative, skip backward."
1310 (let* ((char (following-char))
1311 (syntax (char-to-string (char-syntax char
))))
1312 (cond ((string= syntax
"w")
1313 ;; Here, we can't use skip-syntax-forward/backward because
1314 ;; they don't pay attention to word-separating-categories,
1315 ;; and thus they will skip over a true word boundary. So,
1316 ;; we simulate the original behavior by using forward-word.
1318 (if (not (looking-at "\\<"))
1320 (if (or (looking-at "\\<") (not (looking-at "\\>")))
1322 ((string= syntax
" ")
1324 (skip-syntax-backward syntax
)
1325 (skip-syntax-forward syntax
)))
1326 ((string= syntax
"_")
1328 (skip-syntax-backward "w_")
1329 (skip-syntax-forward "w_")))
1331 (while (and (not (bobp)) (= (preceding-char) char
))
1334 (while (and (not (eobp)) (= (following-char) char
))
1335 (forward-char 1))))))
1337 (defun mouse-start-end (start end mode
)
1338 "Return a list of region bounds based on START and END according to MODE.
1339 If MODE is 0 then set point to (min START END), mark to (max START END).
1340 If MODE is 1 then set point to start of word at (min START END),
1341 mark to end of word at (max START END).
1342 If MODE is 2 then do the same for lines."
1347 (setq mode
(mod mode
3))
1353 (= (char-syntax (char-after start
)) ?\
())
1354 (if (/= (syntax-class (syntax-after start
)) 4) ; raw syntax code for ?\(
1355 ;; This happens in CC Mode when unbalanced parens in CPP
1356 ;; constructs are given punctuation syntax with
1357 ;; syntax-table text properties. (2016-02-21).
1358 (signal 'scan-error
(list "Containing expression ends prematurely"
1368 (= (char-syntax (char-after start
)) ?\
)))
1369 (if (/= (syntax-class (syntax-after start
)) 5) ; raw syntax code for ?\)
1370 ;; See above comment about CC Mode.
1371 (signal 'scan-error
(list "Unbalanced parentheses" start start
))
1372 (list (save-excursion
1373 (goto-char (1+ start
))
1380 (= (char-syntax (char-after start
)) ?
\"))
1381 (let ((open (or (eq start
(point-min))
1383 (goto-char (- start
1))
1384 (looking-at "\\s(\\|\\s \\|\\s>")))))
1394 (list (save-excursion
1397 (goto-char (1+ start
))
1403 (list (save-excursion
1405 (mouse-skip-word -
1)
1412 (list (save-excursion
1414 (line-beginning-position 1))
1420 ;; Subroutine: set the mark where CLICK happened,
1421 ;; but don't do anything else.
1422 (defun mouse-set-mark-fast (click)
1423 (mouse-minibuffer-check click
)
1424 (let ((posn (event-start click
)))
1425 (select-window (posn-window posn
))
1426 (if (numberp (posn-point posn
))
1427 (push-mark (posn-point posn
) t t
))))
1429 (defun mouse-undouble-last-event (events)
1430 (let* ((index (1- (length events
)))
1431 (last (nthcdr index events
))
1433 (basic (event-basic-type event
))
1434 (old-modifiers (event-modifiers event
))
1435 (modifiers (delq 'double
(delq 'triple
(copy-sequence old-modifiers
))))
1438 ;; Use reverse, not nreverse, since event-modifiers
1439 ;; does not copy the list it returns.
1440 (cons (event-convert-list (reverse (cons basic modifiers
)))
1444 (if (and (not (equal modifiers old-modifiers
))
1445 (key-binding (apply 'vector events
)))
1450 ;; Momentarily show where the mark is, if highlighting doesn't show it.
1452 (defun mouse-set-mark (click)
1453 "Set mark at the position clicked on with the mouse.
1454 Display cursor at that position for a second.
1455 This must be bound to a mouse click."
1457 (mouse-minibuffer-check click
)
1458 (select-window (posn-window (event-start click
)))
1459 ;; FIXME: Use save-excursion
1460 (let ((point-save (point)))
1462 (progn (mouse-set-point click
)
1464 (or transient-mark-mode
1466 (goto-char point-save
))))
1468 (defun mouse-kill (click)
1469 "Kill the region between point and the mouse click.
1470 The text is saved in the kill ring, as with \\[kill-region]."
1472 (mouse-minibuffer-check click
)
1473 (let* ((posn (event-start click
))
1474 (click-posn (posn-point posn
)))
1475 (select-window (posn-window posn
))
1476 (if (numberp click-posn
)
1477 (kill-region (min (point) click-posn
)
1478 (max (point) click-posn
)))))
1480 (defun mouse-yank-at-click (click arg
)
1481 "Insert the last stretch of killed text at the position clicked on.
1482 Also move point to one end of the text thus inserted (normally the end),
1483 and set mark at the beginning.
1484 Prefix arguments are interpreted as with \\[yank].
1485 If `mouse-yank-at-point' is non-nil, insert at point
1486 regardless of where you click."
1487 (interactive "e\nP")
1488 ;; Give temporary modes such as isearch a chance to turn off.
1489 (run-hooks 'mouse-leave-buffer-hook
)
1490 (when select-active-regions
1491 ;; Without this, confusing things happen upon e.g. inserting into
1492 ;; the middle of an active region.
1494 (or mouse-yank-at-point
(mouse-set-point click
))
1495 (setq this-command
'yank
)
1496 (setq mouse-selection-click-count
0)
1499 (defun mouse-yank-primary (click)
1500 "Insert the primary selection at the position clicked on.
1501 Move point to the end of the inserted text, and set mark at
1502 beginning. If `mouse-yank-at-point' is non-nil, insert at point
1503 regardless of where you click."
1505 ;; Give temporary modes such as isearch a chance to turn off.
1506 (run-hooks 'mouse-leave-buffer-hook
)
1507 ;; Without this, confusing things happen upon e.g. inserting into
1508 ;; the middle of an active region.
1509 (when select-active-regions
1510 (let (select-active-regions)
1512 (or mouse-yank-at-point
(mouse-set-point click
))
1513 (let ((primary (gui-get-primary-selection)))
1515 (insert-for-yank primary
)))
1517 (defun mouse-kill-ring-save (click)
1518 "Copy the region between point and the mouse click in the kill ring.
1519 This does not delete the region; it acts like \\[kill-ring-save]."
1521 (mouse-set-mark-fast click
)
1522 (let (this-command last-command
)
1523 (kill-ring-save (point) (mark t
))))
1525 ;; This function used to delete the text between point and the mouse
1526 ;; whenever it was equal to the front of the kill ring, but some
1527 ;; people found that confusing.
1529 ;; The position of the last invocation of `mouse-save-then-kill'.
1530 (defvar mouse-save-then-kill-posn nil
)
1532 (defun mouse-save-then-kill-delete-region (beg end
)
1533 ;; We must make our own undo boundaries
1534 ;; because they happen automatically only for the current buffer.
1536 (if (or (= beg end
) (eq buffer-undo-list t
))
1537 ;; If we have no undo list in this buffer,
1539 (delete-region beg end
)
1540 ;; Delete, but make the undo-list entry share with the kill ring.
1541 ;; First, delete just one char, so in case buffer is being modified
1542 ;; for the first time, the undo list records that fact.
1543 (let ((inhibit-modification-hooks t
))
1545 (+ beg
(if (> end beg
) 1 -
1))))
1546 (let ((buffer-undo-list buffer-undo-list
))
1547 ;; Undo that deletion--but don't change the undo list!
1548 (let ((inhibit-modification-hooks t
))
1549 (primitive-undo 1 buffer-undo-list
))
1550 ;; Now delete the rest of the specified region,
1551 ;; but don't record it.
1552 (setq buffer-undo-list t
)
1553 (if (/= (length (car kill-ring
)) (- (max end beg
) (min end beg
)))
1554 (error "Lossage in mouse-save-then-kill-delete-region"))
1555 (delete-region beg end
))
1556 (let ((tail buffer-undo-list
))
1557 ;; Search back in buffer-undo-list for the string
1558 ;; that came from deleting one character.
1559 (while (and tail
(not (stringp (car (car tail
)))))
1560 (setq tail
(cdr tail
)))
1561 ;; Replace it with an entry for the entire deleted text.
1563 (setcar tail
(cons (car kill-ring
) (min beg end
))))))
1566 (defun mouse-save-then-kill (click)
1567 "Set the region according to CLICK; the second time, kill it.
1568 CLICK should be a mouse click event.
1570 If the region is inactive, activate it temporarily. Set mark at
1571 the original point, and move point to the position of CLICK.
1573 If the region is already active, adjust it. Normally, do this by
1574 moving point or mark, whichever is closer, to CLICK. But if you
1575 have selected whole words or lines, move point or mark to the
1576 word or line boundary closest to CLICK instead.
1578 If `mouse-drag-copy-region' is non-nil, this command also saves the
1579 new region to the kill ring (replacing the previous kill if the
1580 previous region was just saved to the kill ring).
1582 If this command is called a second consecutive time with the same
1583 CLICK position, kill the region (or delete it
1584 if `mouse-drag-copy-region' is non-nil)"
1586 (mouse-minibuffer-check click
)
1587 (let* ((posn (event-start click
))
1588 (click-pt (posn-point posn
))
1589 (window (posn-window posn
))
1590 (buf (window-buffer window
))
1591 ;; Don't let a subsequent kill command append to this one.
1592 (this-command this-command
)
1593 ;; Check if the user has multi-clicked to select words/lines.
1595 (if (and (eq mouse-selection-click-count-buffer buf
)
1596 (with-current-buffer buf
(mark t
)))
1597 mouse-selection-click-count
1600 ((not (numberp click-pt
)) nil
)
1601 ;; If the user clicked without moving point, kill the region.
1602 ;; This also resets `mouse-selection-click-count'.
1603 ((and (eq last-command
'mouse-save-then-kill
)
1604 (eq click-pt mouse-save-then-kill-posn
)
1605 (eq window
(selected-window)))
1606 (if mouse-drag-copy-region
1607 ;; Region already saved in the previous click;
1608 ;; don't make a duplicate entry, just delete.
1609 (delete-region (mark t
) (point))
1610 (kill-region (mark t
) (point)))
1611 (setq mouse-selection-click-count
0)
1612 (setq mouse-save-then-kill-posn nil
))
1614 ;; Otherwise, if there is a suitable region, adjust it by moving
1615 ;; one end (whichever is closer) to CLICK-PT.
1616 ((or (with-current-buffer buf
(region-active-p))
1617 (and (eq window
(selected-window))
1619 (or (and (eq last-command
'mouse-save-then-kill
)
1620 mouse-save-then-kill-posn
)
1621 (and (memq last-command
'(mouse-drag-region
1623 (or mark-even-if-inactive
1624 (not transient-mark-mode
))))))
1625 (select-window window
)
1626 (let* ((range (mouse-start-end click-pt click-pt click-count
)))
1627 (if (< (abs (- click-pt
(mark t
)))
1628 (abs (- click-pt
(point))))
1629 (set-mark (car range
))
1630 (goto-char (nth 1 range
)))
1631 (setq deactivate-mark nil
)
1632 (mouse-set-region-1)
1633 (when mouse-drag-copy-region
1634 ;; Region already copied to kill-ring once, so replace.
1635 (kill-new (filter-buffer-substring (mark t
) (point)) t
))
1636 ;; Arrange for a repeated mouse-3 to kill the region.
1637 (setq mouse-save-then-kill-posn click-pt
)))
1639 ;; Otherwise, set the mark where point is and move to CLICK-PT.
1641 (select-window window
)
1642 (mouse-set-mark-fast click
)
1643 (let ((before-scroll (with-current-buffer buf point-before-scroll
)))
1644 (if before-scroll
(goto-char before-scroll
)))
1645 (exchange-point-and-mark)
1646 (mouse-set-region-1)
1647 (when mouse-drag-copy-region
1648 (kill-new (filter-buffer-substring (mark t
) (point))))
1649 (setq mouse-save-then-kill-posn click-pt
)))))
1652 (global-set-key [M-mouse-1
] 'mouse-start-secondary
)
1653 (global-set-key [M-drag-mouse-1
] 'mouse-set-secondary
)
1654 (global-set-key [M-down-mouse-1
] 'mouse-drag-secondary
)
1655 (global-set-key [M-mouse-3
] 'mouse-secondary-save-then-kill
)
1656 (global-set-key [M-mouse-2
] 'mouse-yank-secondary
)
1658 (defconst mouse-secondary-overlay
1659 (let ((ol (make-overlay (point-min) (point-min))))
1661 (overlay-put ol
'face
'secondary-selection
)
1663 "An overlay which records the current secondary selection.
1664 It is deleted when there is no secondary selection.")
1666 (defvar mouse-secondary-click-count
0)
1668 ;; A marker which records the specified first end for a secondary selection.
1670 (defvar mouse-secondary-start nil
)
1672 (defun mouse-start-secondary (click)
1673 "Set one end of the secondary selection to the position clicked on.
1674 Use \\[mouse-secondary-save-then-kill] to set the other end
1675 and complete the secondary selection."
1677 (mouse-minibuffer-check click
)
1678 (let ((posn (event-start click
)))
1679 (with-current-buffer (window-buffer (posn-window posn
))
1680 ;; Cancel any preexisting secondary selection.
1681 (delete-overlay mouse-secondary-overlay
)
1682 (if (numberp (posn-point posn
))
1684 (or mouse-secondary-start
1685 (setq mouse-secondary-start
(make-marker)))
1686 (move-marker mouse-secondary-start
(posn-point posn
)))))))
1688 (defun mouse-set-secondary (click)
1689 "Set the secondary selection to the text that the mouse is dragged over.
1690 This must be bound to a mouse drag event."
1692 (mouse-minibuffer-check click
)
1693 (let ((posn (event-start click
))
1695 (end (event-end click
)))
1696 (with-current-buffer (window-buffer (posn-window posn
))
1697 (if (numberp (posn-point posn
))
1698 (setq beg
(posn-point posn
)))
1699 (move-overlay mouse-secondary-overlay beg
(posn-point end
))
1702 (buffer-substring (overlay-start mouse-secondary-overlay
)
1703 (overlay-end mouse-secondary-overlay
))))))
1705 (defun mouse-drag-secondary (start-event)
1706 "Set the secondary selection to the text that the mouse is dragged over.
1707 Highlight the drag area as you move the mouse.
1708 This must be bound to a button-down mouse event.
1709 The function returns a non-nil value if it creates a secondary selection."
1711 (mouse-minibuffer-check start-event
)
1712 (let* ((echo-keystrokes 0)
1713 (start-posn (event-start start-event
))
1714 (start-point (posn-point start-posn
))
1715 (start-window (posn-window start-posn
))
1716 (bounds (window-edges start-window
))
1717 (top (nth 1 bounds
))
1718 (bottom (if (window-minibuffer-p start-window
)
1720 ;; Don't count the mode line.
1721 (1- (nth 3 bounds
))))
1722 (click-count (1- (event-click-count start-event
))))
1723 (with-current-buffer (window-buffer start-window
)
1724 (setq mouse-secondary-click-count click-count
)
1725 (if (> (mod click-count
3) 0)
1726 ;; Double or triple press: make an initial selection
1727 ;; of one word or line.
1728 (let ((range (mouse-start-end start-point start-point click-count
)))
1729 (set-marker mouse-secondary-start nil
)
1730 (move-overlay mouse-secondary-overlay
(car range
) (nth 1 range
)
1731 (window-buffer start-window
)))
1732 ;; Single-press: cancel any preexisting secondary selection.
1733 (or mouse-secondary-start
1734 (setq mouse-secondary-start
(make-marker)))
1735 (set-marker mouse-secondary-start start-point
)
1736 (delete-overlay mouse-secondary-overlay
))
1737 ;; FIXME: Use mouse-drag-track!
1738 (let (event end end-point
)
1741 (setq event
(read-event))
1742 (or (mouse-movement-p event
)
1743 (memq (car-safe event
) '(switch-frame select-window
))))
1745 (if (memq (car-safe event
) '(switch-frame select-window
))
1747 (setq end
(event-end event
)
1748 end-point
(posn-point end
))
1750 ;; Are we moving within the original window?
1751 ((and (eq (posn-window end
) start-window
)
1752 (integer-or-marker-p end-point
))
1753 (let ((range (mouse-start-end start-point end-point
1755 (if (or (/= start-point end-point
)
1756 (null (marker-position mouse-secondary-start
)))
1758 (set-marker mouse-secondary-start nil
)
1759 (move-overlay mouse-secondary-overlay
1760 (car range
) (nth 1 range
))))))
1762 (let ((mouse-row (cdr (cdr (mouse-position)))))
1766 (mouse-scroll-subr start-window
(- mouse-row top
)
1767 mouse-secondary-overlay start-point
))
1768 ((>= mouse-row bottom
)
1769 (mouse-scroll-subr start-window
(1+ (- mouse-row bottom
))
1770 mouse-secondary-overlay start-point
)))))))))
1773 (if (marker-position mouse-secondary-start
)
1774 (save-window-excursion
1775 (delete-overlay mouse-secondary-overlay
)
1776 (gui-set-selection 'SECONDARY nil
)
1777 (select-window start-window
)
1779 (goto-char mouse-secondary-start
)
1784 (buffer-substring (overlay-start mouse-secondary-overlay
)
1785 (overlay-end mouse-secondary-overlay
)))))))))
1787 (defun mouse-yank-secondary (click)
1788 "Insert the secondary selection at the position clicked on.
1789 Move point to the end of the inserted text.
1790 If `mouse-yank-at-point' is non-nil, insert at point
1791 regardless of where you click."
1793 ;; Give temporary modes such as isearch a chance to turn off.
1794 (run-hooks 'mouse-leave-buffer-hook
)
1795 (or mouse-yank-at-point
(mouse-set-point click
))
1796 (let ((secondary (gui-get-selection 'SECONDARY
)))
1798 (insert-for-yank secondary
)
1799 (error "No secondary selection"))))
1801 (defun mouse-kill-secondary ()
1802 "Kill the text in the secondary selection.
1803 This is intended more as a keyboard command than as a mouse command
1804 but it can work as either one.
1806 The current buffer (in case of keyboard use), or the buffer clicked on,
1807 must be the one that the secondary selection is in. This requirement
1808 is to prevent accidents."
1810 (let* ((keys (this-command-keys))
1811 (click (elt keys
(1- (length keys
)))))
1812 (or (eq (overlay-buffer mouse-secondary-overlay
)
1814 (window-buffer (posn-window (event-start click
)))
1816 (error "Select or click on the buffer where the secondary selection is")))
1818 (with-current-buffer (overlay-buffer mouse-secondary-overlay
)
1819 (kill-region (overlay-start mouse-secondary-overlay
)
1820 (overlay-end mouse-secondary-overlay
))))
1821 (delete-overlay mouse-secondary-overlay
))
1823 (defun mouse-secondary-save-then-kill (click)
1824 "Set the secondary selection and save it to the kill ring.
1825 The second time, kill it. CLICK should be a mouse click event.
1827 If you have not called `mouse-start-secondary' in the clicked
1828 buffer, activate the secondary selection and set it between point
1829 and the click position CLICK.
1831 Otherwise, adjust the bounds of the secondary selection.
1832 Normally, do this by moving its beginning or end, whichever is
1833 closer, to CLICK. But if you have selected whole words or lines,
1834 adjust to the word or line boundary closest to CLICK instead.
1836 If this command is called a second consecutive time with the same
1837 CLICK position, kill the secondary selection."
1839 (mouse-minibuffer-check click
)
1840 (let* ((posn (event-start click
))
1841 (click-pt (posn-point posn
))
1842 (window (posn-window posn
))
1843 (buf (window-buffer window
))
1844 ;; Don't let a subsequent kill command append to this one.
1845 (this-command this-command
)
1846 ;; Check if the user has multi-clicked to select words/lines.
1848 (if (eq (overlay-buffer mouse-secondary-overlay
) buf
)
1849 mouse-secondary-click-count
1851 (beg (overlay-start mouse-secondary-overlay
))
1852 (end (overlay-end mouse-secondary-overlay
)))
1855 ((not (numberp click-pt
)) nil
)
1857 ;; If the secondary selection is not active in BUF, activate it.
1858 ((not (eq buf
(or (overlay-buffer mouse-secondary-overlay
)
1859 (if mouse-secondary-start
1860 (marker-buffer mouse-secondary-start
)))))
1861 (select-window window
)
1862 (setq mouse-secondary-start
(make-marker))
1863 (move-marker mouse-secondary-start
(point))
1864 (move-overlay mouse-secondary-overlay
(point) click-pt buf
)
1865 (kill-ring-save (point) click-pt
))
1867 ;; If the user clicked without moving point, delete the secondary
1868 ;; selection. This also resets `mouse-secondary-click-count'.
1869 ((and (eq last-command
'mouse-secondary-save-then-kill
)
1870 (eq click-pt mouse-save-then-kill-posn
)
1871 (eq window
(selected-window)))
1872 (mouse-save-then-kill-delete-region beg end
)
1873 (delete-overlay mouse-secondary-overlay
)
1874 (setq mouse-secondary-click-count
0)
1875 (setq mouse-save-then-kill-posn nil
))
1877 ;; Otherwise, if there is a suitable secondary selection overlay,
1878 ;; adjust it by moving one end (whichever is closer) to CLICK-PT.
1879 ((and beg
(eq buf
(overlay-buffer mouse-secondary-overlay
)))
1880 (let* ((range (mouse-start-end click-pt click-pt click-count
)))
1881 (if (< (abs (- click-pt beg
))
1882 (abs (- click-pt end
)))
1883 (move-overlay mouse-secondary-overlay
(car range
) end
)
1884 (move-overlay mouse-secondary-overlay beg
(nth 1 range
))))
1885 (setq deactivate-mark nil
)
1886 (if (eq last-command
'mouse-secondary-save-then-kill
)
1887 ;; If the front of the kill ring comes from an immediately
1888 ;; previous use of this command, replace the entry.
1890 (buffer-substring (overlay-start mouse-secondary-overlay
)
1891 (overlay-end mouse-secondary-overlay
))
1893 (let (deactivate-mark)
1894 (copy-region-as-kill (overlay-start mouse-secondary-overlay
)
1895 (overlay-end mouse-secondary-overlay
))))
1896 (setq mouse-save-then-kill-posn click-pt
))
1898 ;; Otherwise, set the secondary selection overlay.
1900 (select-window window
)
1901 (if mouse-secondary-start
1902 ;; All we have is one end of a selection, so put the other
1904 (let ((start (+ 0 mouse-secondary-start
)))
1905 (kill-ring-save start click-pt
)
1906 (move-overlay mouse-secondary-overlay start click-pt
)))
1907 (setq mouse-save-then-kill-posn click-pt
))))
1909 ;; Finally, set the window system's secondary selection.
1911 (and (overlay-buffer mouse-secondary-overlay
)
1912 (setq str
(buffer-substring (overlay-start mouse-secondary-overlay
)
1913 (overlay-end mouse-secondary-overlay
)))
1915 (gui-set-selection 'SECONDARY str
))))
1917 (defun secondary-selection-exist-p ()
1918 "Return non-nil if the secondary selection exists in the current buffer."
1919 (memq mouse-secondary-overlay
(overlays-in (point-min) (point-max))))
1921 (defun secondary-selection-to-region ()
1922 "Set beginning and end of the region to those of the secondary selection.
1923 This puts mark and point at the beginning and the end of the
1924 secondary selection, respectively. This works when the secondary
1925 selection exists and the region does not exist in current buffer;
1926 the secondary selection will be deleted afterward.
1927 If the region is active, or the secondary selection doesn't exist,
1928 this function does nothing."
1929 (when (and (not (region-active-p))
1930 (secondary-selection-exist-p))
1931 (let ((beg (overlay-start mouse-secondary-overlay
))
1932 (end (overlay-end mouse-secondary-overlay
)))
1935 ;; Delete the secondary selection on current buffer.
1936 (delete-overlay mouse-secondary-overlay
)))
1938 (defun secondary-selection-from-region ()
1939 "Set beginning and end of the secondary selection to those of the region.
1940 When there is no region, this function does nothing."
1941 (when (region-active-p) ; Create the secondary selection from the region.
1942 (delete-overlay mouse-secondary-overlay
) ; Delete the secondary selection even on a different buffer.
1943 (move-overlay mouse-secondary-overlay
(region-beginning) (region-end))))
1946 (defcustom mouse-buffer-menu-maxlen
20
1947 "Number of buffers in one pane (submenu) of the buffer menu.
1948 If we have lots of buffers, divide them into groups of
1949 `mouse-buffer-menu-maxlen' and make a pane (or submenu) for each one."
1952 (defcustom mouse-buffer-menu-mode-mult
4
1953 "Group the buffers by the major mode groups on \\[mouse-buffer-menu]?
1954 This number which determines (in a hairy way) whether \\[mouse-buffer-menu]
1955 will split the buffer menu by the major modes (see
1956 `mouse-buffer-menu-mode-groups') or just by menu length.
1957 Set to 1 (or even 0!) if you want to group by major mode always, and to
1958 a large number if you prefer a mixed multitude. The default is 4."
1962 (defvar mouse-buffer-menu-mode-groups
1963 (mapcar (lambda (arg) (cons (purecopy (car arg
)) (purecopy (cdr arg
))))
1964 '(("Info\\|Help\\|Apropos\\|Man" .
"Help")
1965 ("\\bVM\\b\\|\\bMH\\b\\|Message\\|Mail\\|Group\\|Score\\|Summary\\|Article"
1970 ("Outline" .
"Text")
1971 ("\\(HT\\|SG\\|X\\|XHT\\)ML" .
"SGML")
1972 ("log\\|diff\\|vc\\|cvs\\|Annotate" .
"Version Control") ; "Change Management"?
1973 ("Threads\\|Memory\\|Disassembly\\|Breakpoints\\|Frames\\|Locals\\|Registers\\|Inferior I/O\\|Debugger"
1976 "How to group various major modes together in \\[mouse-buffer-menu].
1977 Each element has the form (REGEXP . GROUPNAME).
1978 If the major mode's name string matches REGEXP, use GROUPNAME instead.")
1980 (defun mouse-buffer-menu (event)
1981 "Pop up a menu of buffers for selection with the mouse.
1982 This switches buffers in the window that you clicked on,
1983 and selects that window."
1985 (mouse-minibuffer-check event
)
1986 (let ((buf (x-popup-menu event
(mouse-buffer-menu-map)))
1987 (window (posn-window (event-start event
))))
1990 (if (framep window
) (frame-selected-window window
)
1992 (switch-to-buffer buf
))))
1994 (defun mouse-buffer-menu-map ()
1995 ;; Make an alist of elements that look like (MENU-ITEM . BUFFER).
1996 (let ((buffers (buffer-list)) split-by-major-mode sum-of-squares
)
1997 (dolist (buf buffers
)
1998 ;; Divide all buffers into buckets for various major modes.
1999 ;; Each bucket looks like (MODE NAMESTRING BUFFERS...).
2000 (with-current-buffer buf
2001 (let* ((adjusted-major-mode major-mode
) elt
)
2002 (dolist (group mouse-buffer-menu-mode-groups
)
2003 (when (string-match (car group
) (format-mode-line mode-name
))
2004 (setq adjusted-major-mode
(cdr group
))))
2005 (setq elt
(assoc adjusted-major-mode split-by-major-mode
))
2007 (setq elt
(list adjusted-major-mode
2008 (if (stringp adjusted-major-mode
)
2010 (format-mode-line mode-name nil nil buf
)))
2011 split-by-major-mode
(cons elt split-by-major-mode
)))
2012 (or (memq buf
(cdr (cdr elt
)))
2013 (setcdr (cdr elt
) (cons buf
(cdr (cdr elt
))))))))
2014 ;; Compute the sum of squares of sizes of the major-mode buckets.
2015 (let ((tail split-by-major-mode
))
2016 (setq sum-of-squares
0)
2018 (setq sum-of-squares
2020 (let ((len (length (cdr (cdr (car tail
)))))) (* len len
))))
2021 (setq tail
(cdr tail
))))
2022 (if (< (* sum-of-squares mouse-buffer-menu-mode-mult
)
2023 (* (length buffers
) (length buffers
)))
2024 ;; Subdividing by major modes really helps, so let's do it.
2025 (let (subdivided-menus (buffers-left (length buffers
)))
2026 ;; Sort the list to put the most popular major modes first.
2027 (setq split-by-major-mode
2028 (sort split-by-major-mode
2029 (function (lambda (elt1 elt2
)
2030 (> (length elt1
) (length elt2
))))))
2031 ;; Make a separate submenu for each major mode
2032 ;; that has more than one buffer,
2033 ;; unless all the remaining buffers are less than 1/10 of them.
2034 (while (and split-by-major-mode
2035 (and (> (length (car split-by-major-mode
)) 3)
2036 (> (* buffers-left
10) (length buffers
))))
2037 (let ((this-mode-list (mouse-buffer-menu-alist
2038 (cdr (cdr (car split-by-major-mode
))))))
2040 (setq subdivided-menus
2042 (nth 1 (car split-by-major-mode
))
2044 subdivided-menus
))))
2046 (- buffers-left
(length (cdr (car split-by-major-mode
)))))
2047 (setq split-by-major-mode
(cdr split-by-major-mode
)))
2048 ;; If any major modes are left over,
2049 ;; make a single submenu for them.
2050 (if split-by-major-mode
2052 (mouse-buffer-menu-alist
2053 ;; we don't need split-by-major-mode any more,
2054 ;; so we can ditch it with nconc (mapcan).
2055 (mapcan 'cddr split-by-major-mode
))))
2057 (setq subdivided-menus
2058 (cons (cons "Others" others-list
)
2059 subdivided-menus
)))))
2060 (cons "Buffer Menu" (nreverse subdivided-menus
)))
2062 (mouse-buffer-menu-split "Select Buffer"
2063 (mouse-buffer-menu-alist buffers
))))))
2065 (defun mouse-buffer-menu-alist (buffers)
2071 (function (lambda (elt1 elt2
)
2072 (string< (buffer-name elt1
) (buffer-name elt2
))))))
2075 (or (eq ?\s
(aref (buffer-name (car tail
)) 0))
2078 (length (buffer-name (car tail
))))))
2079 (setq tail
(cdr tail
)))
2082 (let ((elt (car tail
)))
2083 (if (/= (aref (buffer-name elt
) 0) ?\s
)
2088 (format "%%-%ds %%s%%s %%s" maxlen
)
2090 (if (buffer-modified-p elt
) "*" " ")
2091 (with-current-buffer elt
2092 (if buffer-read-only
"%" " "))
2093 (or (buffer-file-name elt
)
2094 (with-current-buffer elt
2095 (if list-buffers-directory
2097 list-buffers-directory
)))
2101 (setq tail
(cdr tail
)))
2102 ;; Compensate for the reversal that the above loop does.
2105 (defun mouse-buffer-menu-split (title alist
)
2106 ;; If we have lots of buffers, divide them into groups of 20
2107 ;; and make a pane (or submenu) for each one.
2108 (if (> (length alist
) (/ (* mouse-buffer-menu-maxlen
3) 2))
2109 (let ((alist alist
) sublists next
2112 ;; Pull off the next mouse-buffer-menu-maxlen buffers
2113 ;; and make them the next element of sublist.
2114 (setq next
(nthcdr mouse-buffer-menu-maxlen alist
))
2116 (setcdr (nthcdr (1- mouse-buffer-menu-maxlen
) alist
)
2118 (setq sublists
(cons (cons (format "Buffers %d" i
) alist
)
2122 (nreverse sublists
))
2123 ;; Few buffers--put them all in one pane.
2124 (list (cons title alist
))))
2126 (define-obsolete-function-alias
2127 'mouse-choose-completion
'choose-completion
"23.2")
2131 (defun font-menu-add-default ()
2132 (let* ((default (frame-parameter nil
'font
))
2133 (font-alist x-fixed-font-alist
)
2134 (elt (or (assoc "Misc" font-alist
) (nth 1 font-alist
))))
2135 (if (assoc "Default" elt
)
2136 (delete (assoc "Default" elt
) elt
))
2138 (cons (list "Default" default
)
2141 (defvar x-fixed-font-alist
2143 (purecopy "Font Menu")
2147 (lambda (arg) (cons (purecopy (car arg
)) (purecopy (cdr arg
))))
2148 ;; For these, we specify the pixel height and width.
2150 ("6x10" "-misc-fixed-medium-r-normal--10-*-*-*-c-60-iso8859-1" "6x10")
2152 "-misc-fixed-medium-r-semicondensed--12-*-*-*-c-60-iso8859-1" "6x12")
2154 "-misc-fixed-medium-r-semicondensed--13-*-*-*-c-60-iso8859-1" "6x13")
2155 ("7x13" "-misc-fixed-medium-r-normal--13-*-*-*-c-70-iso8859-1" "7x13")
2156 ("7x14" "-misc-fixed-medium-r-normal--14-*-*-*-c-70-iso8859-1" "7x14")
2157 ("8x13" "-misc-fixed-medium-r-normal--13-*-*-*-c-80-iso8859-1" "8x13")
2158 ("9x15" "-misc-fixed-medium-r-normal--15-*-*-*-c-90-iso8859-1" "9x15")
2159 ("10x20" "-misc-fixed-medium-r-normal--20-*-*-*-c-100-iso8859-1" "10x20")
2160 ("11x18" "-misc-fixed-medium-r-normal--18-*-*-*-c-110-iso8859-1" "11x18")
2161 ("12x24" "-misc-fixed-medium-r-normal--24-*-*-*-c-120-iso8859-1" "12x24")
2164 "-schumacher-clean-medium-r-normal--8-*-*-*-c-50-iso8859-1")
2166 "-schumacher-clean-medium-r-normal--8-*-*-*-c-60-iso8859-1")
2168 "-schumacher-clean-medium-r-normal--8-*-*-*-c-80-iso8859-1")
2170 "-schumacher-clean-medium-r-normal--10-*-*-*-c-80-iso8859-1")
2172 "-schumacher-clean-medium-r-normal--14-*-*-*-c-80-iso8859-1")
2174 "-schumacher-clean-medium-r-normal--16-*-*-*-c-80-iso8859-1")
2176 ("sony 8x16" "-sony-fixed-medium-r-normal--16-*-*-*-c-80-iso8859-1")
2177 ;; We don't seem to have these; who knows what they are.
2178 ;; ("fg-18" "fg-18")
2179 ;; ("fg-25" "fg-25")
2180 ("lucidasanstypewriter-12" "-b&h-lucidatypewriter-medium-r-normal-sans-*-120-*-*-*-*-iso8859-1")
2181 ("lucidasanstypewriter-bold-14" "-b&h-lucidatypewriter-bold-r-normal-sans-*-140-*-*-*-*-iso8859-1")
2182 ("lucidasanstypewriter-bold-24"
2183 "-b&h-lucidatypewriter-bold-r-normal-sans-*-240-*-*-*-*-iso8859-1")
2184 ;; ("lucidatypewriter-bold-r-24" "-b&h-lucidatypewriter-bold-r-normal-sans-24-240-75-75-m-140-iso8859-1")
2185 ;; ("fixed-medium-20" "-misc-fixed-medium-*-*-*-20-*-*-*-*-*-*-*")
2189 (purecopy "Courier")
2191 (lambda (arg) (cons (purecopy (car arg
)) (purecopy (cdr arg
))))
2192 ;; For these, we specify the point height.
2193 '(("8" "-adobe-courier-medium-r-normal--*-80-*-*-m-*-iso8859-1")
2194 ("10" "-adobe-courier-medium-r-normal--*-100-*-*-m-*-iso8859-1")
2195 ("12" "-adobe-courier-medium-r-normal--*-120-*-*-m-*-iso8859-1")
2196 ("14" "-adobe-courier-medium-r-normal--*-140-*-*-m-*-iso8859-1")
2197 ("18" "-adobe-courier-medium-r-normal--*-180-*-*-m-*-iso8859-1")
2198 ("24" "-adobe-courier-medium-r-normal--*-240-*-*-m-*-iso8859-1")
2199 ("8 bold" "-adobe-courier-bold-r-normal--*-80-*-*-m-*-iso8859-1")
2200 ("10 bold" "-adobe-courier-bold-r-normal--*-100-*-*-m-*-iso8859-1")
2201 ("12 bold" "-adobe-courier-bold-r-normal--*-120-*-*-m-*-iso8859-1")
2202 ("14 bold" "-adobe-courier-bold-r-normal--*-140-*-*-m-*-iso8859-1")
2203 ("18 bold" "-adobe-courier-bold-r-normal--*-180-*-*-m-*-iso8859-1")
2204 ("24 bold" "-adobe-courier-bold-r-normal--*-240-*-*-m-*-iso8859-1")
2205 ("8 slant" "-adobe-courier-medium-o-normal--*-80-*-*-m-*-iso8859-1")
2206 ("10 slant" "-adobe-courier-medium-o-normal--*-100-*-*-m-*-iso8859-1")
2207 ("12 slant" "-adobe-courier-medium-o-normal--*-120-*-*-m-*-iso8859-1")
2208 ("14 slant" "-adobe-courier-medium-o-normal--*-140-*-*-m-*-iso8859-1")
2209 ("18 slant" "-adobe-courier-medium-o-normal--*-180-*-*-m-*-iso8859-1")
2210 ("24 slant" "-adobe-courier-medium-o-normal--*-240-*-*-m-*-iso8859-1")
2211 ("8 bold slant" "-adobe-courier-bold-o-normal--*-80-*-*-m-*-iso8859-1")
2212 ("10 bold slant" "-adobe-courier-bold-o-normal--*-100-*-*-m-*-iso8859-1")
2213 ("12 bold slant" "-adobe-courier-bold-o-normal--*-120-*-*-m-*-iso8859-1")
2214 ("14 bold slant" "-adobe-courier-bold-o-normal--*-140-*-*-m-*-iso8859-1")
2215 ("18 bold slant" "-adobe-courier-bold-o-normal--*-180-*-*-m-*-iso8859-1")
2216 ("24 bold slant" "-adobe-courier-bold-o-normal--*-240-*-*-m-*-iso8859-1")
2218 "X fonts suitable for use in Emacs.")
2220 (declare-function generate-fontset-menu
"fontset" ())
2222 (defun mouse-select-font ()
2223 "Prompt for a font name, using `x-popup-menu', and return it."
2225 (unless (display-multi-font-p)
2226 (error "Cannot change fonts on this display"))
2229 (if (listp last-nonmenu-event
)
2231 (list '(0 0) (selected-window)))
2232 (append x-fixed-font-alist
2233 (list (generate-fontset-menu))))))
2235 (declare-function text-scale-mode
"face-remap")
2237 (defun mouse-set-font (&rest fonts
)
2238 "Set the default font for the selected frame.
2239 The argument FONTS is a list of font names; the first valid font
2240 in this list is used.
2242 When called interactively, pop up a menu and allow the user to
2245 (progn (unless (display-multi-font-p)
2246 (error "Cannot change fonts on this display"))
2248 (if (listp last-nonmenu-event
)
2250 (list '(0 0) (selected-window)))
2251 ;; Append list of fontsets currently defined.
2252 (append x-fixed-font-alist
(list (generate-fontset-menu))))))
2258 (set-frame-font (car fonts
))
2259 (setq font
(car fonts
))
2262 (setq fonts
(cdr fonts
)))))
2264 (error "Font not found")))))
2266 (defvar mouse-appearance-menu-map nil
)
2267 (declare-function x-select-font
"xfns.c" (&optional frame ignored
)) ; USE_GTK
2268 (declare-function buffer-face-mode-invoke
"face-remap"
2269 (face arg
&optional interactive
))
2270 (declare-function font-face-attributes
"font.c" (font &optional frame
))
2271 (defvar w32-use-w32-font-dialog
)
2272 (defvar w32-fixed-font-alist
)
2274 (defun mouse-appearance-menu (event)
2275 "Show a menu for changing the default face in the current buffer."
2277 (require 'face-remap
)
2278 (when (display-multi-font-p)
2279 (with-selected-window (car (event-start event
))
2280 (if mouse-appearance-menu-map
2281 nil
; regenerate new fonts
2282 ;; Initialize mouse-appearance-menu-map
2283 (setq mouse-appearance-menu-map
2284 (make-sparse-keymap "Change Default Buffer Face"))
2285 (define-key mouse-appearance-menu-map
[face-remap-reset-base
]
2286 '(menu-item "Reset to Default" face-remap-reset-base
))
2287 (define-key mouse-appearance-menu-map
[text-scale-decrease
]
2288 '(menu-item "Decrease Buffer Text Size" text-scale-decrease
))
2289 (define-key mouse-appearance-menu-map
[text-scale-increase
]
2290 '(menu-item "Increase Buffer Text Size" text-scale-increase
))
2292 (if (and (functionp 'x-select-font
)
2293 (or (not (boundp 'w32-use-w32-font-dialog
))
2294 w32-use-w32-font-dialog
))
2295 (define-key mouse-appearance-menu-map
[x-select-font
]
2296 '(menu-item "Change Buffer Font..." x-select-font
))
2297 ;; If the select-font is unavailable, construct a menu.
2298 (let ((font-submenu (make-sparse-keymap "Change Text Font"))
2299 (font-alist (cdr (append
2300 (if (eq system-type
'windows-nt
)
2301 w32-fixed-font-alist
2303 (list (generate-fontset-menu))))))
2304 (dolist (family font-alist
)
2305 (let* ((submenu-name (car family
))
2306 (submenu-map (make-sparse-keymap submenu-name
)))
2307 (dolist (font (cdr family
))
2308 (let ((font-name (car font
))
2310 (if (string= font-name
"")
2311 (define-key submenu-map
[space]
2313 (setq font-symbol (intern (cadr font)))
2314 (define-key submenu-map (vector font-symbol)
2315 (list 'menu-item (car font) font-symbol)))))
2316 (define-key font-submenu (vector (intern submenu-name))
2317 (list 'menu-item submenu-name submenu-map))))
2318 (define-key mouse-appearance-menu-map [font-submenu]
2319 (list 'menu-item "Change Text Font" font-submenu)))))
2320 (let ((choice (x-popup-menu event mouse-appearance-menu-map)))
2321 (setq choice (nth (1- (length choice)) choice))
2322 (cond ((eq choice 'text-scale-increase)
2323 (text-scale-increase 1))
2324 ((eq choice 'text-scale-decrease)
2325 (text-scale-increase -1))
2326 ((eq choice 'face-remap-reset-base)
2328 (buffer-face-mode 0))
2330 ;; Either choice == 'x-select-font, or choice is a
2331 ;; symbol whose name is a font.
2332 (let ((font (if (eq choice 'x-select-font)
2334 (symbol-name choice))))
2335 (buffer-face-mode-invoke
2336 (if (fontp font 'font-spec)
2338 (font-face-attributes font))
2339 t (called-interactively-p 'interactive)))))))))
2342 ;; Drag and drop support.
2343 (defcustom mouse-drag-and-drop-region nil
2344 "If non-nil, dragging the mouse drags the region, if it exists.
2345 If the value is a modifier, such as `control' or `shift' or
2346 `meta', then if that modifier key is pressed when dropping the
2347 region, text is copied instead of being cut."
2349 (const :tag "Disable dragging the region" nil)
2352 `(const :tag ,(format "Enable, but copy with the %s modifier"
2355 '(alt super hyper shift control meta))
2356 (other :tag "Enable dragging the region" t))
2359 (defcustom mouse-drag-and-drop-region-cut-when-buffers-differ nil
2360 "If non-nil, cut text also when source and destination buffers differ.
2361 If this option is nil, `mouse-drag-and-drop-region' will leave
2362 the text in the source buffer alone when dropping it in a
2363 different buffer. If this is non-nil, it will cut the text just
2364 as it does when dropping text in the source buffer."
2368 (defcustom mouse-drag-and-drop-region-show-tooltip 256
2369 "If non-nil, text is shown by a tooltip in a graphic display.
2370 If this option is nil, `mouse-drag-and-drop-region' does not show
2371 tooltips. If this is t, it shows the entire text dragged in a
2372 tooltip. If this is an integer (as with the default value of
2373 256), it will show that many characters of the dragged text in
2378 (defcustom mouse-drag-and-drop-region-show-cursor t
2379 "If non-nil, move point with mouse cursor during dragging.
2380 If this is nil, `mouse-drag-and-drop-region' leaves point alone.
2381 Otherwise, it will move point together with the mouse cursor and,
2382 in addition, temporarily highlight the original region with the
2383 `mouse-drag-and-drop-region' face."
2387 (defface mouse-drag-and-drop-region '((t :inherit region))
2388 "Face to highlight original text during dragging.
2389 This face is used by `mouse-drag-and-drop-region' to temporarily
2390 highlight the original region when
2391 `mouse-drag-and-drop-region-show-cursor' is non-nil."
2394 (defun mouse-drag-and-drop-region (event)
2395 "Move text in the region to point where mouse is dragged to.
2396 The transportation of text is also referred as `drag and drop'.
2397 When text is dragged over to a different buffer, or if a
2398 modifier key was pressed when dropping, and the value of the
2399 variable `mouse-drag-and-drop-region' is that modifier, the text
2400 is copied instead of being cut."
2402 (let* ((mouse-button (event-basic-type last-input-event))
2403 (mouse-drag-and-drop-region-show-tooltip
2404 (when (and mouse-drag-and-drop-region-show-tooltip
2405 (display-multi-frame-p)
2407 mouse-drag-and-drop-region-show-tooltip))
2408 (start (region-beginning))
2411 (buffer (current-buffer))
2412 (window (selected-window))
2413 (text-from-read-only buffer-read-only)
2414 (mouse-drag-and-drop-overlay (make-overlay start end))
2416 point-to-paste-read-only
2423 value-selection ; This remains nil when event was "click".
2428 ;; STATES stores for each window on this frame its start and point
2429 ;; positions so we can restore them on all windows but for the one
2430 ;; where the drop occurs. For inter-frame drags we'll have to do
2431 ;; this for all windows on all visible frames. In addition we save
2432 ;; also the cursor type for the window's buffer so we can restore it
2433 ;; in case we modified it.
2434 ;; https://lists.gnu.org/archive/html/emacs-devel/2017-12/msg00090.html
2441 (copy-marker (window-start window))
2442 (copy-marker (window-point window))
2443 (with-current-buffer (window-buffer window)
2449 ;; When event was "click" instead of "drag", skip loop.
2451 (setq event (read-key)) ; read-event or read-key
2452 (or (mouse-movement-p event)
2453 ;; Handle `mouse-autoselect-window'.
2454 (eq (car-safe event) 'select-window)))
2455 ;; Obtain the dragged text in region. When the loop was
2456 ;; skipped, value-selection remains nil.
2457 (unless value-selection
2458 (setq value-selection (buffer-substring start end))
2459 (when mouse-drag-and-drop-region-show-tooltip
2460 (let ((text-size mouse-drag-and-drop-region-show-tooltip))
2462 (if (and (integerp text-size)
2463 (> (length value-selection) text-size))
2465 (substring value-selection 0 (/ text-size 2))
2467 (substring value-selection (- (/ text-size 2)) -1))
2470 ;; Check if selected text is read-only.
2471 (setq text-from-read-only (or text-from-read-only
2472 (get-text-property start 'read-only)
2474 (next-single-char-property-change
2475 start 'read-only nil end)
2477 (setq window-to-paste (posn-window (event-end event)))
2478 (setq point-to-paste (posn-point (event-end event)))
2479 ;; Set nil when target buffer is minibuffer.
2480 (setq buffer-to-paste (let (buf)
2481 (when (windowp window-to-paste)
2482 (setq buf (window-buffer window-to-paste))
2483 (when (not (minibufferp buf))
2485 (setq cursor-in-text-area (and window-to-paste
2489 (when cursor-in-text-area
2490 ;; Check if point under mouse is read-only.
2491 (save-window-excursion
2492 (select-window window-to-paste)
2493 (setq point-to-paste-read-only
2494 (or buffer-read-only
2495 (get-text-property point-to-paste 'read-only))))
2497 ;; Check if "drag but negligible". Operation "drag but
2498 ;; negligible" is defined as drag-and-drop the text to
2499 ;; the original region. When modifier is pressed, the
2500 ;; text will be inserted to inside of the original
2502 (setq drag-but-negligible
2503 (and (eq (overlay-buffer mouse-drag-and-drop-overlay)
2505 (<= (overlay-start mouse-drag-and-drop-overlay)
2508 (overlay-end mouse-drag-and-drop-overlay)))))
2511 (if mouse-drag-and-drop-region-show-tooltip
2512 (tooltip-show text-tooltip)
2515 ;; Show cursor and highlight the original region.
2516 (when mouse-drag-and-drop-region-show-cursor
2517 ;; Modify cursor even when point is out of frame.
2518 (setq cursor-type (cond
2519 ((not cursor-in-text-area)
2521 ((or point-to-paste-read-only
2522 drag-but-negligible)
2526 (when cursor-in-text-area
2527 (overlay-put mouse-drag-and-drop-overlay
2528 'face 'mouse-drag-and-drop-region)
2529 (deactivate-mark) ; Maintain region in other window.
2530 (mouse-set-point event)))))
2533 (when mouse-drag-and-drop-region-show-tooltip (tooltip-hide))
2535 ;; Check if modifier was pressed on drop.
2536 (setq no-modifier-on-drop
2537 (not (member mouse-drag-and-drop-region (event-modifiers event))))
2539 ;; Check if event was "click".
2540 (setq clicked (not value-selection))
2542 ;; Restore status on drag to outside of text-area or non-mouse input.
2543 (when (or (not cursor-in-text-area)
2544 (not (equal (event-basic-type event) mouse-button)))
2545 (setq drag-but-negligible t
2546 no-modifier-on-drop t))
2548 ;; Do not modify any buffers when event is "click",
2549 ;; "drag but negligible", or "drag to read-only".
2550 (let* ((mouse-drag-and-drop-region-cut-when-buffers-differ
2551 (if no-modifier-on-drop
2552 mouse-drag-and-drop-region-cut-when-buffers-differ
2553 (not mouse-drag-and-drop-region-cut-when-buffers-differ)))
2554 (wanna-paste-to-same-buffer (equal buffer-to-paste buffer))
2555 (wanna-cut-on-same-buffer (and wanna-paste-to-same-buffer
2556 no-modifier-on-drop))
2557 (wanna-cut-on-other-buffer
2558 (and (not wanna-paste-to-same-buffer)
2559 mouse-drag-and-drop-region-cut-when-buffers-differ))
2560 (cannot-paste (or point-to-paste-read-only
2561 (when (or wanna-cut-on-same-buffer
2562 wanna-cut-on-other-buffer)
2563 text-from-read-only))))
2566 ;; Move point within region.
2569 (mouse-set-point event))
2570 ;; Undo operation. Set back the original text as region.
2571 ((or (and drag-but-negligible
2572 no-modifier-on-drop)
2574 ;; Inform user either source or destination buffer cannot be modified.
2575 (when (and (not drag-but-negligible)
2577 (message "Buffer is read-only"))
2579 ;; Select source window back and restore region.
2580 ;; (set-window-point window point)
2581 (select-window window)
2583 (setq deactivate-mark nil)
2587 ;; * DESTINATION BUFFER::
2588 ;; Insert the text to destination buffer under mouse.
2589 (select-window window-to-paste)
2590 (setq window-exempt window-to-paste)
2591 (goto-char point-to-paste)
2593 (insert value-selection)
2594 ;; On success, set the text as region on destination buffer.
2595 (when (not (equal (mark) (point)))
2596 (setq deactivate-mark nil)
2599 ;; * SOURCE BUFFER::
2600 ;; Set back the original text as region or delete the original
2601 ;; text, on source buffer.
2602 (if wanna-paste-to-same-buffer
2603 ;; When source buffer and destination buffer are the same,
2604 ;; remove the original text.
2605 (when no-modifier-on-drop
2606 (let (deactivate-mark)
2607 (delete-region (overlay-start mouse-drag-and-drop-overlay)
2608 (overlay-end mouse-drag-and-drop-overlay))))
2609 ;; When source buffer and destination buffer are different,
2610 ;; keep (set back the original text as region) or remove the
2612 (select-window window) ; Select window with source buffer.
2613 (goto-char point) ; Move point to the original text on source buffer.
2615 (if mouse-drag-and-drop-region-cut-when-buffers-differ
2616 ;; Remove the dragged text from source buffer like
2618 (delete-region (overlay-start mouse-drag-and-drop-overlay)
2619 (overlay-end mouse-drag-and-drop-overlay))
2620 ;; Set back the dragged text as region on source buffer
2621 ;; like operation `copy'.
2623 (select-window window-to-paste))))))
2626 (delete-overlay mouse-drag-and-drop-overlay)
2628 ;; Restore old states but for the window where the drop
2629 ;; occurred. Restore cursor types for all windows.
2630 (dolist (state states)
2631 (let ((window (car state)))
2632 (when (and window-exempt
2633 (not (eq window window-exempt)))
2634 (set-window-start window (nth 1 state) 'noforce)
2635 (set-marker (nth 1 state) nil)
2636 ;; If window is selected, the following automatically sets
2637 ;; point for that window's buffer.
2638 (set-window-point window (nth 2 state))
2639 (set-marker (nth 2 state) nil))
2640 (with-current-buffer (window-buffer window)
2641 (setq cursor-type (nth 3 state)))))))
2644 ;;; Bindings for mouse commands.
2646 (global-set-key [down-mouse-1] 'mouse-drag-region)
2647 (global-set-key [mouse-1] 'mouse-set-point)
2648 (global-set-key [drag-mouse-1] 'mouse-set-region)
2650 (defun mouse--strip-first-event (_prompt)
2651 (substring (this-single-command-raw-keys) 1))
2653 (define-key function-key-map [left-fringe mouse-1] 'mouse--strip-first-event)
2654 (define-key function-key-map [right-fringe mouse-1] 'mouse--strip-first-event)
2656 (global-set-key [mouse-2] 'mouse-yank-primary)
2657 ;; Allow yanking also when the corresponding cursor is "in the fringe".
2658 (define-key function-key-map [right-fringe mouse-2] 'mouse--strip-first-event)
2659 (define-key function-key-map [left-fringe mouse-2] 'mouse--strip-first-event)
2660 (global-set-key [mouse-3] 'mouse-save-then-kill)
2661 (define-key function-key-map [right-fringe mouse-3] 'mouse--strip-first-event)
2662 (define-key function-key-map [left-fringe mouse-3] 'mouse--strip-first-event)
2664 ;; By binding these to down-going events, we let the user use the up-going
2665 ;; event to make the selection, saving a click.
2666 (global-set-key [C-down-mouse-1] 'mouse-buffer-menu)
2667 (if (not (eq system-type 'ms-dos))
2668 (global-set-key [S-down-mouse-1] 'mouse-appearance-menu))
2669 ;; C-down-mouse-2 is bound in facemenu.el.
2670 (global-set-key [C-down-mouse-3]
2671 `(menu-item ,(purecopy "Menu Bar") ignore
2673 (if (zerop (or (frame-parameter nil 'menu-bar-lines) 0))
2674 (mouse-menu-bar-map)
2675 (mouse-menu-major-mode-map)))))
2677 ;; Binding mouse-1 to mouse-select-window when on mode-, header-, or
2678 ;; vertical-line prevents Emacs from signaling an error when the mouse
2679 ;; button is released after dragging these lines, on non-toolkit
2681 (global-set-key [header-line down-mouse-1] 'mouse-drag-header-line)
2682 (global-set-key [header-line mouse-1] 'mouse-select-window)
2683 ;; (global-set-key [mode-line drag-mouse-1] 'mouse-select-window)
2684 (global-set-key [mode-line down-mouse-1] 'mouse-drag-mode-line)
2685 (global-set-key [mode-line mouse-1] 'mouse-select-window)
2686 (global-set-key [mode-line mouse-2] 'mouse-delete-other-windows)
2687 (global-set-key [mode-line mouse-3] 'mouse-delete-window)
2688 (global-set-key [mode-line C-mouse-2] 'mouse-split-window-horizontally)
2689 (global-set-key [vertical-scroll-bar C-mouse-2] 'mouse-split-window-vertically)
2690 (global-set-key [horizontal-scroll-bar C-mouse-2] 'mouse-split-window-horizontally)
2691 (global-set-key [vertical-line down-mouse-1] 'mouse-drag-vertical-line)
2692 (global-set-key [vertical-line mouse-1] 'mouse-select-window)
2693 (global-set-key [vertical-line C-mouse-2] 'mouse-split-window-vertically)
2694 (global-set-key [right-divider down-mouse-1] 'mouse-drag-vertical-line)
2695 (global-set-key [right-divider mouse-1] 'ignore)
2696 (global-set-key [right-divider C-mouse-2] 'mouse-split-window-vertically)
2697 (global-set-key [bottom-divider down-mouse-1] 'mouse-drag-mode-line)
2698 (global-set-key [bottom-divider mouse-1] 'ignore)
2699 (global-set-key [bottom-divider C-mouse-2] 'mouse-split-window-horizontally)
2700 (global-set-key [left-edge down-mouse-1] 'mouse-drag-left-edge)
2701 (global-set-key [left-edge mouse-1] 'ignore)
2702 (global-set-key [top-left-corner down-mouse-1] 'mouse-drag-top-left-corner)
2703 (global-set-key [top-left-corner mouse-1] 'ignore)
2704 (global-set-key [top-edge down-mouse-1] 'mouse-drag-top-edge)
2705 (global-set-key [top-edge mouse-1] 'ignore)
2706 (global-set-key [top-right-corner down-mouse-1] 'mouse-drag-top-right-corner)
2707 (global-set-key [top-right-corner mouse-1] 'ignore)
2708 (global-set-key [right-edge down-mouse-1] 'mouse-drag-right-edge)
2709 (global-set-key [right-edge mouse-1] 'ignore)
2710 (global-set-key [bottom-right-corner down-mouse-1] 'mouse-drag-bottom-right-corner)
2711 (global-set-key [bottom-right-corner mouse-1] 'ignore)
2712 (global-set-key [bottom-edge down-mouse-1] 'mouse-drag-bottom-edge)
2713 (global-set-key [bottom-edge mouse-1] 'ignore)
2714 (global-set-key [bottom-left-corner down-mouse-1] 'mouse-drag-bottom-left-corner)
2715 (global-set-key [bottom-left-corner mouse-1] 'ignore)
2719 ;;; mouse.el ends here