From 5db74b60fc263ec68de78542b2a334c1b19d70df Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= <mattiase@acm.org>
Date: Fri, 25 Oct 2019 11:16:39 +0200
Subject: [PATCH] Mouse rectangular region selection (bug#38013)

Make it possible to select a rectangular region using the mouse.
The modifier is customisable and defaults to meta.
The modifier for mouse secondary selection is now also customisable and
defaults to nil (disabled).

* lisp/mouse.el (mouse-scroll-subr): Add ADJUST argument.
(mouse-drag-region-rectangle): New.
(mouse--global-with-modifiers, mouse--set-secondary-selection-bindings)
(mouse-secondary-selection-modifiers)
(mouse--set-rectangular-region-selection-bindings)
(mouse-region-rectangle-modifiers): New defcustoms with helper functions.
---
 lisp/mouse.el | 123 +++++++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 117 insertions(+), 6 deletions(-)

diff --git a/lisp/mouse.el b/lisp/mouse.el
index 4a351f7be2..738f5403d8 100644
--- a/lisp/mouse.el
+++ b/lisp/mouse.el
@@ -1045,10 +1045,12 @@ mouse-scroll-min-lines
 of lines specified by this variable."
   :type 'integer)
 
-(defun mouse-scroll-subr (window jump &optional overlay start)
+(defun mouse-scroll-subr (window jump &optional overlay start adjust)
   "Scroll the window WINDOW, JUMP lines at a time, until new input arrives.
 If OVERLAY is an overlay, let it stretch from START to the far edge of
 the newly visible text.
+ADJUST, if non-nil, is a function, without arguments, to call after
+setting point.
 Upon exit, point is at the far edge of the newly visible text."
   (cond
    ((and (> jump 0) (< jump mouse-scroll-min-lines))
@@ -1077,6 +1079,8 @@ mouse-scroll-subr
 		   ;; so that we don't mess up the selected window.
 		   (or (eq window (selected-window))
 		       (goto-char opoint))
+                   (when adjust
+                     (funcall adjust))
 		   (sit-for mouse-scroll-delay)))))
     (or (eq window (selected-window))
 	(goto-char opoint))))
@@ -1666,11 +1670,40 @@ mouse-save-then-kill
       (setq mouse-save-then-kill-posn click-pt)))))
 
 
-(global-set-key [M-mouse-1] 'mouse-start-secondary)
-(global-set-key [M-drag-mouse-1] 'mouse-set-secondary)
-(global-set-key [M-down-mouse-1] 'mouse-drag-secondary)
-(global-set-key [M-mouse-3] 'mouse-secondary-save-then-kill)
-(global-set-key [M-mouse-2] 'mouse-yank-secondary)
+(defun mouse--global-with-modifiers (base modifiers command)
+  "Globally bind BASE + MODIFIERS to COMMAND."
+  (global-set-key (vector (event-convert-list (append modifiers (list base))))
+                  command))
+
+(defun mouse--set-secondary-selection-bindings (mods activate)
+  "Set global mouse bindings using MODS for secondary selection.
+If ACTIVATE is nil, remove those bindings."
+  (when mods
+    (mouse--global-with-modifiers
+     'mouse-1 mods (and activate 'mouse-start-secondary))
+    (mouse--global-with-modifiers
+     'drag-mouse-1 mods (and activate 'mouse-set-secondary))
+    (mouse--global-with-modifiers
+     'down-mouse-1 mods (and activate 'mouse-drag-secondary))
+    (mouse--global-with-modifiers
+     'mouse-3 mods (and activate 'mouse-secondary-save-then-kill))
+    (mouse--global-with-modifiers
+     'mouse-2 mods (and activate 'mouse-yank-secondary))))
+
+(defcustom mouse-secondary-selection-modifiers '()
+  "The modifier keys for secondary selection using the mouse.
+If none, mouse secondary selection is disabled."
+  :group 'mouse
+  :type '(set (const meta) (const control) (const shift)
+              (const super) (const hyper))
+  :version "27.1"
+  :set (lambda (variable new-value)
+         (when (boundp 'mouse-secondary-selection-modifiers)
+           (mouse--set-secondary-selection-bindings
+            mouse-secondary-selection-modifiers nil))
+         (set-default variable new-value)
+         (mouse--set-secondary-selection-bindings
+          mouse-secondary-selection-modifiers t)))
 
 (defconst mouse-secondary-overlay
   (let ((ol (make-overlay (point-min) (point-min))))
@@ -1960,6 +1993,84 @@ secondary-selection-from-region
     (move-overlay mouse-secondary-overlay (region-beginning) (region-end))))
 
 
+(defun mouse-drag-region-rectangle (start-event)
+  "Set the region to the rectangle that the mouse is dragged over.
+This must be bound to a button-down mouse event."
+  (interactive "e")
+  (mouse-minibuffer-check start-event)
+  (deactivate-mark)
+  (let* ((start-pos (event-start start-event))
+         (col-row (posn-col-row start-pos)))
+    (posn-set-point start-pos)
+    (rectangle-mark-mode)
+    ;; Tell the rectangle selection about the exact column, since it might
+    ;; not correspond exactly to a valid position in the text.
+    (rectangle--col-pos (car col-row) 'mark)
+    (rectangle--col-pos (car col-row) 'point))
+  (let* ((scroll-margin 0)
+         (start-posn (event-start start-event))
+         (start-point (posn-point start-posn))
+         (start-window (posn-window start-posn))
+         (bounds (window-edges start-window))
+         (top (nth 1 bounds))
+         (bottom (if (window-minibuffer-p start-window)
+                     (nth 3 bounds)
+                   (1- (nth 3 bounds))))
+         event)
+    (track-mouse
+      (while (progn
+               (setq event (read-event))
+               (mouse-movement-p event))
+        (let* ((posn (event-end event))
+               (window (posn-window posn))
+               (mouse-pos (mouse-position))
+               (mouse-col (cadr mouse-pos))
+               (mouse-row (cddr mouse-pos)))
+          (if (and (eq window start-window)
+                   mouse-row
+                   (<= top mouse-row (1- bottom)))
+              ;; Drag inside the same window.
+              (progn
+                (posn-set-point posn)
+                (rectangle--col-pos mouse-col 'point))
+            ;; Drag outside the window: scroll.
+            (cond
+             ((null mouse-row))
+             ((< mouse-row top)
+              (mouse-scroll-subr
+               start-window (- mouse-row top) nil start-point
+               (lambda () (rectangle--col-pos mouse-col 'point))))
+             ((>= mouse-row bottom)
+              (mouse-scroll-subr
+               start-window (1+ (- mouse-row bottom)) nil start-point
+               (lambda () (rectangle--col-pos mouse-col 'point)))))))))
+    (when (equal (rectangle-dimensions (mark) (point)) '(0 . 1))
+      ;; No nontrivial region selected; deactivate rectangle mode.
+      (rectangle-mark-mode -1))))
+
+(defun mouse--set-rectangular-region-selection-bindings (mods activate)
+  "Set global mouse bindings using MODS for rectangular selection.
+If ACTIVATE is nil, remove those bindings."
+  (when mods
+    (mouse--global-with-modifiers 'down-mouse-1 mods
+                                  (and activate 'mouse-drag-region-rectangle))))
+
+(defcustom mouse-region-rectangle-modifiers '(meta)
+  "The modifier keys for rectangular region selection using the mouse.
+If none, mouse rectangular region selection is disabled."
+  :group 'mouse
+  :type '(set (const meta) (const control) (const shift)
+              (const super) (const hyper))
+  :version "27.1"
+  :set (lambda (variable new-value)
+         (when (boundp 'mouse-region-rectangle-modifiers)
+           (mouse--set-rectangular-region-selection-bindings
+            mouse-region-rectangle-modifiers nil))
+         (set-default variable new-value)
+         (mouse--set-rectangular-region-selection-bindings
+          mouse-region-rectangle-modifiers t)))
+
+
 (defcustom mouse-buffer-menu-maxlen 20
   "Number of buffers in one pane (submenu) of the buffer menu.
 If we have lots of buffers, divide them into groups of
-- 
2.21.0 (Apple Git-122)

