Support changing font size using mouse wheel

* lisp/mwheel.el (mouse-wheel-mode): Support changing font size (text
scaling) using mouse wheel.  (Bug#28182)
(mouse-wheel-scroll-amount): Bind the Ctrl modifier to text scaling.
(mwheel-installed-text-scale-bindings): New variable.
(mouse-wheel--remove-bindings): New helper function for
'mouse-wheel-mode'.

* doc/emacs/frames.texi (Mouse Commands): Document this feature.
* etc/NEWS: Announce it.

3 files changed, 71 insertions, 26 deletions

diff --git a/doc/emacs/frames.texi b/doc/emacs/frames.texi
index ba1424aa2a3..869b77d86bd 100644
--- a/doc/emacs/frames.texi
+++ b/doc/emacs/frames.texi
@@ -201,10 +201,12 @@ deactivating the mark.  @xref{Shift Selection}.
 @vindex mouse-wheel-progressive-speed
   Some mice have a ``wheel'' which can be used for scrolling.  Emacs
 supports scrolling windows with the mouse wheel, by default, on most
-graphical displays.  To toggle this feature, use @kbd{M-x
-mouse-wheel-mode}.  The variables @code{mouse-wheel-follow-mouse} and
-@code{mouse-wheel-scroll-amount} determine where and by how much
-buffers are scrolled.  The variable
+graphical displays.  There is also support for increasing or
+decreasing the height of the default face, by default bound to
+scrolling with the @key{Ctrl} modifier.  To toggle this feature, use
+@kbd{M-x mouse-wheel-mode}.  The variables
+@code{mouse-wheel-follow-mouse} and @code{mouse-wheel-scroll-amount}
+determine where and by how much buffers are scrolled.  The variable
 @code{mouse-wheel-progressive-speed} determines whether the scroll
 speed is linked to how fast you move the wheel.
 
diff --git a/etc/NEWS b/etc/NEWS
index 4a323002686..208db12519b 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -2309,6 +2309,18 @@ bool vector.
 ** 'regexp-quote' may return its argument string.
 If the argument needs no quoting, it can be returned instead of a copy.
 
++++
+** Mouse scroll up and down with control key modifier changes font size.
+Previously, the control key modifier was used to scroll up or down by
+an amount which was close to near a full screen.  This is now instead
+available by scrolling with the meta modifier key.
+
+To get the old behaviour back, customize the variable
+'mouse-wheel-scroll-amount', or add the following to your init file:
+
+(customize-set-variable 'mouse-wheel-scroll-amount
+                        '(5 ((shift) . 1) ((control) . nil)))
+
 
 * Lisp Changes in Emacs 27.1
 
diff --git a/lisp/mwheel.el b/lisp/mwheel.el
index 4862406fa19..9b67e71886f 100644
--- a/lisp/mwheel.el
+++ b/lisp/mwheel.el
@@ -84,17 +84,22 @@ set to the event sent when clicking on the mouse wheel button."
   :group 'mouse
   :type 'number)
 
-(defcustom mouse-wheel-scroll-amount '(5 ((shift) . 1) ((control) . nil))
+(defcustom mouse-wheel-scroll-amount
+  '(5 ((shift) . 1) ((meta) . nil) ((control) . text-scale))
   "Amount to scroll windows by when spinning the mouse wheel.
 This is an alist mapping the modifier key to the amount to scroll when
 the wheel is moved with the modifier key depressed.
-Elements of the list have the form (MODIFIERS . AMOUNT) or just AMOUNT if
-MODIFIERS is nil.
+Elements of the list have the form (MODIFIER . AMOUNT) or just AMOUNT if
+MODIFIER is nil.
 
 AMOUNT should be the number of lines to scroll, or nil for near full
 screen.  It can also be a floating point number, specifying the fraction of
 a full screen to scroll.  A near full screen is `next-screen-context-lines'
-less than a full screen."
+less than a full screen.
+
+If AMOUNT is the symbol text-scale, this means that with
+MODIFIER, the mouse wheel will change the face height instead of
+scrolling."
   :group 'mouse
   :type '(cons
           (choice :tag "Normal"
@@ -105,20 +110,22 @@ less than a full screen."
                    (repeat (choice :tag "modifier"
                                    (const alt) (const control) (const hyper)
                                    (const meta) (const shift) (const super)))
-                   (choice :tag "scroll amount"
-                           (const :tag "Full screen" :value nil)
-                           (integer :tag "Specific # of lines")
-                           (float :tag "Fraction of window"))))
+                   (choice :tag "action"
+                           (const :tag "Scroll full screen" :value nil)
+                           (integer :tag "Scroll specific # of lines")
+                           (float :tag "Scroll fraction of window"))))
           (repeat
            (cons
             (repeat (choice :tag "modifier"
                             (const alt) (const control) (const hyper)
                             (const meta) (const shift) (const super)))
-            (choice :tag "scroll amount"
-                    (const :tag "Full screen" :value nil)
-                    (integer :tag "Specific # of lines")
-                    (float :tag "Fraction of window")))))
-  :set 'mouse-wheel-change-button)
+            (choice :tag "action"
+                    (const :tag "Scroll full screen" :value nil)
+                    (integer :tag "Scroll specific # of lines")
+                    (float :tag "Scroll fraction of window")
+                    (const :tag "Change face size" :value text-scale)))))
+  :set 'mouse-wheel-change-button
+  :version "27.1")
 
 (defcustom mouse-wheel-progressive-speed t
   "If non-nil, the faster the user moves the wheel, the faster the scrolling.
@@ -316,6 +323,15 @@ non-Windows systems."
 (put 'mwheel-scroll 'scroll-command t)
 
 (defvar mwheel-installed-bindings nil)
+(defvar mwheel-installed-text-scale-bindings nil)
+
+(defun mouse-wheel--remove-bindings (bindings funs)
+  "Remove key BINDINGS if they're bound to any function in FUNS.
+BINDINGS is a list of key bindings, FUNS is a list of functions.
+This is a helper function for `mouse-wheel-mode'."
+  (dolist (key bindings)
+    (when (memq (lookup-key (current-global-map) key) funs)
+      (global-unset-key key))))
 
 (define-minor-mode mouse-wheel-mode
   "Toggle mouse wheel support (Mouse Wheel mode)."
@@ -328,17 +344,32 @@ non-Windows systems."
   :global t
   :group 'mouse
   ;; Remove previous bindings, if any.
-  (while mwheel-installed-bindings
-    (let ((key (pop mwheel-installed-bindings)))
-      (when (eq (lookup-key (current-global-map) key) 'mwheel-scroll)
-        (global-unset-key key))))
+  (mouse-wheel--remove-bindings mwheel-installed-bindings
+                                '(mwheel-scroll))
+  (mouse-wheel--remove-bindings mwheel-installed-text-scale-bindings
+                                '(text-scale-increase
+                                  text-scale-decrease))
+  (setq mwheel-installed-bindings nil)
+  (setq mwheel-installed-text-scale-bindings nil)
   ;; Setup bindings as needed.
   (when mouse-wheel-mode
-    (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event mouse-wheel-right-event mouse-wheel-left-event))
-      (dolist (key (mapcar (lambda (amt) `[(,@(if (consp amt) (car amt)) ,event)])
-                           mouse-wheel-scroll-amount))
-        (global-set-key key 'mwheel-scroll)
-        (push key mwheel-installed-bindings)))))
+    (dolist (binding mouse-wheel-scroll-amount)
+      (cond
+       ;; Bindings for changing font size.
+       ((and (consp binding) (eq (cdr binding) 'text-scale))
+        (let ((increase-key `[,(list (caar binding) mouse-wheel-down-event)])
+              (decrease-key `[,(list (caar binding) mouse-wheel-up-event)]))
+          (global-set-key increase-key 'text-scale-increase)
+          (global-set-key decrease-key 'text-scale-decrease)
+          (push increase-key mwheel-installed-text-scale-bindings)
+          (push decrease-key mwheel-installed-text-scale-bindings)))
+       ;; Bindings for scrolling.
+       (t
+        (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event
+                             mouse-wheel-right-event mouse-wheel-left-event))
+          (let ((key `[(,@(if (consp binding) (car binding)) ,event)]))
+            (global-set-key key 'mwheel-scroll)
+            (push key mwheel-installed-bindings))))))))
 
 ;;; Compatibility entry point
 ;; preloaded ;;;###autoload