diff options
Diffstat (limited to 'lisp/mouse.el')
| -rw-r--r-- | lisp/mouse.el | 440 |
1 files changed, 375 insertions, 65 deletions
diff --git a/lisp/mouse.el b/lisp/mouse.el index 89e5d7c48a3..4f9c49ce463 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -46,7 +46,7 @@ :type 'boolean) (defcustom mouse-drag-copy-region nil - "If non-nil, copy to kill-ring upon mouse adjustments of the region. + "If non-nil, copy to kill ring upon mouse adjustments of the region. This affects `mouse-save-then-kill' (\\[mouse-save-then-kill]) in addition to mouse drags. @@ -180,7 +180,7 @@ items `Turn Off' and `Help'." `(keymap ,(format "%s - %s" indicator (capitalize - (replace-regexp-in-string + (string-replace "-" " " (format "%S" minor-mode)))) (turn-off menu-item "Turn off minor mode" ,mm-fun) (help menu-item "Help for minor mode" @@ -277,11 +277,302 @@ not it is actually displayed." minor-mode-menus))) +;; Context menus. + +(defcustom context-menu-functions '(context-menu-undo + context-menu-region + context-menu-middle-separator + context-menu-local + context-menu-minor) + "List of functions that produce the contents of the context menu. +Each function receives the menu and the mouse click event as its arguments +and should return the same menu with changes such as added new menu items." + :type '(repeat + (choice (function-item context-menu-undo) + (function-item context-menu-region) + (function-item context-menu-middle-separator) + (function-item context-menu-toolbar) + (function-item context-menu-global) + (function-item context-menu-local) + (function-item context-menu-minor) + (function-item context-menu-buffers) + (function-item context-menu-vc) + (function-item context-menu-ffap) + (function :tag "Custom function"))) + :version "28.1") + +(defcustom context-menu-filter-function nil + "Function that can filter the list produced by `context-menu-functions'." + :type '(choice (const nil) function) + :version "28.1") + +(defun context-menu-map (&optional click) + "Return menu map constructed for context near mouse CLICK. +The menu is populated by calling functions from `context-menu-functions'. +Each function receives the menu and the mouse click event +and returns the same menu after adding own menu items to the composite menu. +When there is a text property `context-menu-function' at CLICK, +it overrides all functions from `context-menu-functions'. +At the end, it's possible to modify the final menu by specifying +the function `context-menu-filter-function'." + (let* ((menu (make-sparse-keymap (propertize "Context Menu" 'hide t))) + (click (or click last-input-event)) + (fun (mouse-posn-property (event-start click) + 'context-menu-function))) + + (if (functionp fun) + (setq menu (funcall fun menu click)) + (run-hook-wrapped 'context-menu-functions + (lambda (fun) + (setq menu (funcall fun menu click)) + nil))) + + ;; Remove duplicate separators + (let ((l menu)) + (while (consp l) + (when (and (equal (cdr-safe (car l)) menu-bar-separator) + (equal (cdr-safe (cadr l)) menu-bar-separator)) + (setcdr l (cddr l))) + (setq l (cdr l)))) + + (when (functionp context-menu-filter-function) + (setq menu (funcall context-menu-filter-function menu click))) + menu)) + +(defun context-menu-middle-separator (menu _click) + "Add separator to the middle of the context menu. +Some context functions add menu items below the separator." + (define-key-after menu [middle-separator] menu-bar-separator) + menu) + +(defun context-menu-toolbar (menu _click) + "Populate MENU with submenus from the tool bar." + (run-hooks 'activate-menubar-hook 'menu-bar-update-hook) + (define-key-after menu [separator-toolbar] menu-bar-separator) + (map-keymap (lambda (key binding) + (when (consp binding) + (define-key-after menu (vector key) + (copy-sequence binding)))) + (lookup-key global-map [tool-bar])) + menu) + +(defun context-menu-global (menu _click) + "Populate MENU with submenus from the global menu." + (run-hooks 'activate-menubar-hook 'menu-bar-update-hook) + (define-key-after menu [separator-global] menu-bar-separator) + (map-keymap (lambda (key binding) + (when (consp binding) + (define-key-after menu (vector key) + (copy-sequence binding)))) + (menu-bar-keymap global-map)) + menu) + +(defun context-menu-local (menu _click) + "Populate MENU with submenus provided by major mode." + (run-hooks 'activate-menubar-hook 'menu-bar-update-hook) + (define-key-after menu [separator-local] menu-bar-separator) + (let ((keymap (local-key-binding [menu-bar]))) + (when keymap + (map-keymap (lambda (key binding) + (when (consp binding) + (define-key-after menu (vector key) + (copy-sequence binding)))) + keymap))) + menu) + +(defun context-menu-minor (menu _click) + "Populate MENU with submenus provided by minor modes." + (run-hooks 'activate-menubar-hook 'menu-bar-update-hook) + (define-key-after menu [separator-minor] menu-bar-separator) + (dolist (mode (reverse (minor-mode-key-binding [menu-bar]))) + (when (and (consp mode) (symbol-value (car mode))) + (map-keymap (lambda (key binding) + (when (consp binding) + (define-key-after menu (vector key) + (copy-sequence binding)))) + (cdr mode)))) + menu) + +(defun context-menu-buffers (menu _click) + "Populate MENU with the buffer submenus to buffer switching." + (run-hooks 'activate-menubar-hook 'menu-bar-update-hook) + (define-key-after menu [separator-buffers] menu-bar-separator) + (map-keymap (lambda (key binding) + (when (consp binding) + (define-key-after menu (vector key) + (copy-sequence binding)))) + (mouse-buffer-menu-keymap)) + menu) + +(defun context-menu-vc (menu _click) + "Populate MENU with Version Control commands." + (define-key-after menu [separator-vc] menu-bar-separator) + (define-key-after menu [vc-menu] vc-menu-entry) + menu) + +(defun context-menu-undo (menu _click) + "Populate MENU with undo commands." + (define-key-after menu [separator-undo] menu-bar-separator) + (when (and (not buffer-read-only) + (not (eq t buffer-undo-list)) + (if (eq last-command 'undo) + (listp pending-undo-list) + (consp buffer-undo-list))) + (define-key-after menu [undo] + `(menu-item ,(if (region-active-p) "Undo in Region" "Undo") undo + :help "Undo last edits"))) + (when (and (not buffer-read-only) + (undo--last-change-was-undo-p buffer-undo-list)) + (define-key-after menu [undo-redo] + `(menu-item (if undo-in-region "Redo in Region" "Redo") undo-redo + :help "Redo last undone edits"))) + menu) + +(defun context-menu-region (menu click) + "Populate MENU with region commands." + (define-key-after menu [separator-region] menu-bar-separator) + (when (and mark-active (not buffer-read-only)) + (define-key-after menu [cut] + '(menu-item "Cut" kill-region + :help + "Cut (kill) text in region between mark and current position"))) + (when mark-active + (define-key-after menu [copy] + ;; ns-win.el said: Substitute a Copy function that works better + ;; under X (for GNUstep). + `(menu-item "Copy" ,(if (featurep 'ns) + 'ns-copy-including-secondary + 'kill-ring-save) + :help "Copy text in region between mark and current position" + :keys ,(if (featurep 'ns) + "\\[ns-copy-including-secondary]" + "\\[kill-ring-save]")))) + (when (and (or (gui-backend-selection-exists-p 'CLIPBOARD) + (if (featurep 'ns) ; like paste-from-menu + (cdr yank-menu) + kill-ring)) + (not buffer-read-only)) + (define-key-after menu [paste] + `(menu-item "Paste" mouse-yank-at-click + :help "Paste (yank) text most recently cut/copied"))) + (when (and (cdr yank-menu) (not buffer-read-only)) + (let ((submenu (make-sparse-keymap (propertize "Paste from Kill Menu"))) + (i 0)) + (dolist (item (reverse yank-menu)) + (when (consp item) + (define-key submenu (vector (setq i (1+ i))) + `(menu-item ,(cadr item) + ,(lambda () (interactive) + (mouse-yank-from-menu click (car item))))))) + (define-key-after menu (if (featurep 'ns) [select-paste] [paste-from-menu]) + `(menu-item ,(if (featurep 'ns) "Select and Paste" "Paste from Kill Menu") + ,submenu + :help "Choose a string from the kill ring and paste it")))) + (when (and mark-active (not buffer-read-only)) + (define-key-after menu [clear] + '(menu-item "Clear" delete-active-region + :help + "Delete text in region between mark and current position"))) + + (let ((submenu (make-sparse-keymap (propertize "Select")))) + (define-key-after submenu [mark-whole-buffer] + `(menu-item "All" + ,(lambda (e) (interactive "e") (mark-thing-at-mouse e 'buffer)) + :help "Mark the whole buffer for a subsequent cut/copy")) + (when (let* ((pos (posn-point (event-end click))) + (char (when pos (char-after pos)))) + (or (and char (eq (char-syntax char) ?\")) + (nth 3 (save-excursion (syntax-ppss pos))))) + (define-key-after submenu [mark-string] + `(menu-item "String" + ,(lambda (e) (interactive "e") (mark-thing-at-mouse e 'string)) + :help "Mark the string at click for a subsequent cut/copy"))) + (define-key-after submenu [mark-line] + `(menu-item "Line" + ,(lambda (e) (interactive "e") (mark-thing-at-mouse e 'line)) + :help "Mark the line at click for a subsequent cut/copy")) + (when (region-active-p) + (define-key-after submenu [mark-none] + `(menu-item "None" + ,(lambda (_e) (interactive "e") (deactivate-mark)) + :help "Deactivate the region"))) + + (define-key-after menu [select-region] + `(menu-item "Select" ,submenu))) + menu) + +(defun context-menu-ffap (menu click) + "Populate MENU with commands that find file at point." + (save-excursion + (mouse-set-point click) + (when (ffap-guess-file-name-at-point) + (define-key menu [ffap-separator] menu-bar-separator) + (define-key menu [ffap-at-mouse] + '(menu-item "Find File or URL" ffap-at-mouse + :help "Find file or URL from text around mouse click")))) + menu) + +(defvar context-menu-entry + `(menu-item ,(purecopy "Context Menu") ignore + :filter (lambda (_) (context-menu-map))) + "Menu item that creates the context menu and can be bound to a mouse key.") + +(defvar context-menu-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [mouse-3] nil) + (define-key map [down-mouse-3] context-menu-entry) + (define-key map [menu] #'context-menu-open) + (if (featurep 'w32) + (define-key map [apps] #'context-menu-open)) + (when (featurep 'ns) + (define-key map [C-mouse-1] nil) + (define-key map [C-down-mouse-1] context-menu-entry)) + map) + "Context Menu mode map.") + +(define-minor-mode context-menu-mode + "Toggle Context Menu mode. + +When Context Menu mode is enabled, clicking the mouse button down-mouse-3 +activates the menu whose contents depends on its surrounding context." + :global t :group 'mouse) + +(defun context-menu-open () + "Start key navigation of the context menu. +This is the keyboard interface to \\[context-menu-map]." + (interactive) + (let ((inhibit-mouse-event-check t)) + (popup-menu (context-menu-map) (point)))) + +(global-set-key [S-f10] 'context-menu-open) + +(defun mark-thing-at-mouse (click thing) + "Activate the region around THING found near the mouse CLICK." + (let ((bounds (bounds-of-thing-at-mouse click thing))) + (when bounds + (goto-char (if mouse-select-region-move-to-beginning + (car bounds) (cdr bounds))) + (push-mark (if mouse-select-region-move-to-beginning + (cdr bounds) (car bounds)) + t 'activate)))) + +(defun mouse-yank-from-menu (click string) + "Insert STRING at mouse CLICK." + ;; Give temporary modes such as isearch a chance to turn off. + (run-hooks 'mouse-leave-buffer-hook) + (when select-active-regions + (deactivate-mark)) + (or mouse-yank-at-point (mouse-set-point click)) + (push-mark) + (insert string)) + + ;; Commands that operate on windows. (defun mouse-minibuffer-check (event) (let ((w (posn-window (event-start event)))) - (and (window-minibuffer-p w) + (and (windowp w) + (window-minibuffer-p w) (not (minibuffer-window-active-p w)) (user-error "Minibuffer window is not active"))) ;; Give temporary modes such as isearch a chance to turn off. @@ -1186,9 +1477,10 @@ its value is returned." ;; Mouse clicks in the fringe come with a position in ;; (nth 5). This is useful but is not exactly where we clicked, so ;; don't look up that position's properties! - (and pt (not (memq (posn-area pos) '(left-fringe right-fringe - left-margin right-margin))) - (get-char-property pt property w)))) + (and pt (not (memq (posn-area pos) + '(left-fringe right-fringe + left-margin right-margin tab-bar))) + (get-char-property pt property w)))) (get-char-property pos property))) (defun mouse-on-link-p (pos) @@ -1277,8 +1569,7 @@ The region will be defined with mark and point." (mouse-minibuffer-check start-event) (setq mouse-selection-click-count-buffer (current-buffer)) (deactivate-mark) - (let* ((scroll-margin 0) ; Avoid margin scrolling (Bug#9541). - (start-posn (event-start start-event)) + (let* ((start-posn (event-start start-event)) (start-point (posn-point start-posn)) (start-window (posn-window start-posn)) (_ (with-current-buffer (window-buffer start-window) @@ -1300,65 +1591,84 @@ The region will be defined with mark and point." ;; Don't count the mode line. (1- (nth 3 bounds)))) (click-count (1- (event-click-count start-event))) - ;; Suppress automatic hscrolling, because that is a nuisance - ;; when setting point near the right fringe (but see below). + ;; Save original automatic scrolling behavior (see below). (auto-hscroll-mode-saved auto-hscroll-mode) - (old-track-mouse track-mouse)) + (scroll-margin-saved scroll-margin) + (old-track-mouse track-mouse) + (cleanup (lambda () + (setq track-mouse old-track-mouse) + (setq auto-hscroll-mode auto-hscroll-mode-saved) + (setq scroll-margin scroll-margin-saved)))) + (condition-case err + (progn + (setq mouse-selection-click-count click-count) + + ;; Suppress automatic scrolling near the edges while tracking + ;; movement, as it interferes with the natural dragging behavior + ;; (point will unexpectedly be moved beneath the pointer, making + ;; selections in auto-scrolling margins impossible). + (setq auto-hscroll-mode nil) + (setq scroll-margin 0) + + ;; In case the down click is in the middle of some intangible text, + ;; use the end of that text, and put it in START-POINT. + (if (< (point) start-point) + (goto-char start-point)) + (setq start-point (point)) + + ;; Activate the region, using `mouse-start-end' to determine where + ;; to put point and mark (e.g., double-click will select a word). + (setq-local transient-mark-mode + (if (eq transient-mark-mode 'lambda) + '(only) + (cons 'only transient-mark-mode))) + (let ((range (mouse-start-end start-point start-point click-count))) + (push-mark (nth 0 range) t t) + (goto-char (nth 1 range))) - (setq mouse-selection-click-count click-count) - ;; In case the down click is in the middle of some intangible text, - ;; use the end of that text, and put it in START-POINT. - (if (< (point) start-point) - (goto-char start-point)) - (setq start-point (point)) + (setf (terminal-parameter nil 'mouse-drag-start) start-event) + (setq track-mouse t) - ;; Activate the region, using `mouse-start-end' to determine where - ;; to put point and mark (e.g., double-click will select a word). - (setq-local transient-mark-mode - (if (eq transient-mark-mode 'lambda) - '(only) - (cons 'only transient-mark-mode))) - (let ((range (mouse-start-end start-point start-point click-count))) - (push-mark (nth 0 range) t t) - (goto-char (nth 1 range))) - - (setf (terminal-parameter nil 'mouse-drag-start) start-event) - (setq track-mouse t) - (setq auto-hscroll-mode nil) - - (set-transient-map - (let ((map (make-sparse-keymap))) - (define-key map [switch-frame] #'ignore) - (define-key map [select-window] #'ignore) - (define-key map [mouse-movement] - (lambda (event) (interactive "e") - (let* ((end (event-end event)) - (end-point (posn-point end))) - (unless (eq end-point start-point) - ;; As soon as the user moves, we can re-enable auto-hscroll. - (setq auto-hscroll-mode auto-hscroll-mode-saved) - ;; And remember that we have moved, so mouse-set-region can know - ;; its event is really a drag event. - (setcar start-event 'mouse-movement)) - (if (and (eq (posn-window end) start-window) - (integer-or-marker-p end-point)) - (mouse--drag-set-mark-and-point start-point - end-point click-count) - (let ((mouse-row (cdr (cdr (mouse-position))))) - (cond - ((null mouse-row)) - ((< mouse-row top) - (mouse-scroll-subr start-window (- mouse-row top) - nil start-point)) - ((>= mouse-row bottom) - (mouse-scroll-subr start-window (1+ (- mouse-row bottom)) - nil start-point)))))))) - map) - t (lambda () - (setq track-mouse old-track-mouse) - (setq auto-hscroll-mode auto-hscroll-mode-saved) - (deactivate-mark) - (pop-mark))))) + (set-transient-map + (let ((map (make-sparse-keymap))) + (define-key map [switch-frame] #'ignore) + (define-key map [select-window] #'ignore) + (define-key map [mouse-movement] + (lambda (event) (interactive "e") + (let* ((end (event-end event)) + (end-point (posn-point end))) + (unless (eq end-point start-point) + ;; And remember that we have moved, so mouse-set-region can know + ;; its event is really a drag event. + (setcar start-event 'mouse-movement)) + (if (and (eq (posn-window end) start-window) + (integer-or-marker-p end-point)) + (mouse--drag-set-mark-and-point start-point + end-point click-count) + (let ((mouse-row (cdr (cdr (mouse-position))))) + (cond + ((null mouse-row)) + ((< mouse-row top) + (mouse-scroll-subr start-window (- mouse-row top) + nil start-point)) + ((>= mouse-row bottom) + (mouse-scroll-subr start-window (1+ (- mouse-row bottom)) + nil start-point)))))))) + map) + t (lambda () + (funcall cleanup) + ;; Don't deactivate the mark when the context menu was invoked + ;; by down-mouse-3 immediately after down-mouse-1 and without + ;; releasing the mouse button with mouse-1. This allows to use + ;; region-related context menu to operate on the selected region. + (unless (and context-menu-mode + (eq (car-safe (aref (this-command-keys-vector) 0)) + 'down-mouse-3)) + (deactivate-mark) + (pop-mark))))) + ;; Cleanup on errors + (error (funcall cleanup) + (signal (car err) (cdr err)))))) (defun mouse--drag-set-mark-and-point (start click click-count) (let* ((range (mouse-start-end start click click-count)) @@ -2167,7 +2477,7 @@ a large number if you prefer a mixed multitude. The default is 4." ("Text" . "Text") ("Outline" . "Text") ("\\(HT\\|SG\\|X\\|XHT\\)ML" . "SGML") - ("log\\|diff\\|vc\\|cvs\\|Git\\|Annotate" . "Version Control") + ("\\blog\\b\\|diff\\|\\bvc\\b\\|cvs\\|Git\\|Annotate" . "Version Control") ("Threads\\|Memory\\|Disassembly\\|Breakpoints\\|Frames\\|Locals\\|Registers\\|Inferior I/O\\|Debugger" . "GDB") ("Lisp" . "Lisp"))) |