master 2bc6d82831: Handle modifiers during Haiku DND wheel movement

[Po Lu]

branch: master
commit 2bc6d8283189bcbbf9bceeac5013b9e41a511222
Author: Po Lu <luangruo@yahoo.com>
Commit: Po Lu <luangruo@yahoo.com>

    Handle modifiers during Haiku DND wheel movement
    
    * lisp/term/haiku-win.el (haiku-dnd-modifier-mask)
    (haiku-dnd-wheel-modifier-type): New functions.
    (haiku-handle-drag-wheel): Use them.
    * lisp/x-dnd.el (x-dnd-modifier-mask): Remove outdated comment.
    * src/haikuselect.c (haiku_note_drag_wheel): Pass modifiers to
    wheel function.
    (syms_of_haikuselect): Update doc strings.
---
 lisp/term/haiku-win.el | 62 +++++++++++++++++++++++++++++++++++++++++++++-----
 lisp/x-dnd.el          |  1 -
 src/haikuselect.c      | 13 ++++++-----
 3 files changed, 63 insertions(+), 13 deletions(-)

diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el
index 9d9c31970d..a16169d477 100644
--- a/lisp/term/haiku-win.el
+++ b/lisp/term/haiku-win.el
@@ -489,19 +489,56 @@ Return the number of clicks that were made in quick 
succession."
 
 (defvar haiku-drag-wheel-function)
 
-(defun haiku-handle-drag-wheel (frame x y horizontal up)
+(defun haiku-dnd-modifier-mask (mods)
+  "Return the internal modifier mask for the Emacs modifier state MODS.
+MODS is a single symbol, or a list of symbols such as `shift' or
+`control'."
+  (let ((mask 0))
+    (unless (consp mods)
+      (setq mods (list mods)))
+    (dolist (modifier mods)
+      (cond ((eq modifier 'shift)
+             (setq mask (logior mask ?\S-\0)))
+            ((eq modifier 'control)
+             (setq mask (logior mask ?\C-\0)))
+            ((eq modifier 'meta)
+             (setq mask (logior mask ?\M-\0)))
+            ((eq modifier 'hyper)
+             (setq mask (logior mask ?\H-\0)))
+            ((eq modifier 'super)
+             (setq mask (logior mask ?\s-\0)))
+            ((eq modifier 'alt)
+             (setq mask (logior mask ?\A-\0)))))
+    mask))
+
+(defun haiku-dnd-wheel-modifier-type (flags)
+  "Return the modifier type of an internal modifier mask.
+FLAGS is the internal modifier mask of a turn of the mouse wheel."
+  (let ((modifiers (logior ?\M-\0 ?\C-\0 ?\S-\0
+                          ?\H-\0 ?\s-\0 ?\A-\0)))
+    (catch 'type
+      (dolist (modifier mouse-wheel-scroll-amount)
+        (when (and (consp modifier)
+                   (eq (haiku-dnd-modifier-mask (car modifier))
+                       (logand flags modifiers)))
+          (throw 'type (cdr modifier))))
+      nil)))
+
+(defun haiku-handle-drag-wheel (frame x y horizontal up modifiers)
   "Handle wheel movement during drag-and-drop.
 FRAME is the frame on top of which the wheel moved.
 X and Y are the frame-relative coordinates of the wheel movement.
 HORIZONTAL is whether or not the wheel movement was horizontal.
-UP is whether or not the wheel moved up (or left)."
+UP is whether or not the wheel moved up (or left).
+MODIFIERS is the internal modifier mask of the wheel movement."
   (when (not (equal haiku-last-wheel-direction
                     (cons horizontal up)))
     (setq haiku-last-wheel-direction
           (cons horizontal up))
     (when (consp haiku-dnd-wheel-count)
       (setcar haiku-dnd-wheel-count 0)))
-  (let ((function (cond
+  (let ((type (haiku-dnd-wheel-modifier-type modifiers))
+        (function (cond
                    ((and (not horizontal) (not up))
                     mwheel-scroll-up-function)
                    ((not horizontal)
@@ -512,14 +549,27 @@ UP is whether or not the wheel moved up (or left)."
                    (t (if mouse-wheel-flip-direction
                           mwheel-scroll-left-function
                         mwheel-scroll-right-function))))
-        (timestamp (time-convert nil 1000)))
+        (timestamp (time-convert nil 1000))
+        (amt 1))
+    (cond ((and (eq type 'hscroll)
+                (not horizontal))
+           (setq function (if (not up)
+                              mwheel-scroll-left-function
+                            mwheel-scroll-right-function)))
+          ((and (eq type 'global-text-scale))
+           (setq function 'global-text-scale-adjust
+                 amt (if up 1 -1)))
+          ((and (eq type 'text-scale))
+           (setq function 'text-scale-adjust
+                 amt (if up 1 -1))))
     (when function
       (let ((posn (posn-at-x-y x y frame)))
         (when (windowp (posn-window posn))
           (with-selected-window (posn-window posn)
             (funcall function
-                     (or (and (not mouse-wheel-progressive-speed) 1)
-                         (haiku-note-wheel-click (car timestamp))))))))))
+                     (* amt
+                        (or (and (not mouse-wheel-progressive-speed) 1)
+                            (haiku-note-wheel-click (car timestamp)))))))))))
 
 (setq haiku-drag-wheel-function #'haiku-handle-drag-wheel)
 
diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el
index 10fd9e5dac..bdfe444bc1 100644
--- a/lisp/x-dnd.el
+++ b/lisp/x-dnd.el
@@ -708,7 +708,6 @@ MODS is a single symbol, or a list of symbols such as 
`shift' or
     (unless (consp mods)
       (setq mods (list mods)))
     (dolist (modifier mods)
-      ;; TODO: handle virtual modifiers such as Meta and Hyper.
       (cond ((eq modifier 'shift)
              (setq mask (logior mask 1))) ; ShiftMask
             ((eq modifier 'control)
diff --git a/src/haikuselect.c b/src/haikuselect.c
index 268d8b1ec9..7eb93a2754 100644
--- a/src/haikuselect.c
+++ b/src/haikuselect.c
@@ -1062,8 +1062,9 @@ haiku_note_drag_wheel (struct input_event *ie)
   if (!NILP (Vhaiku_drag_wheel_function)
       && (haiku_dnd_allow_same_frame
          || XFRAME (ie->frame_or_window) != haiku_dnd_frame))
-    safe_call (6, Vhaiku_drag_wheel_function, ie->frame_or_window,
-              ie->x, ie->y, horizontal ? Qt : Qnil, up ? Qt : Qnil);
+    safe_call (7, Vhaiku_drag_wheel_function, ie->frame_or_window,
+              ie->x, ie->y, horizontal ? Qt : Qnil, up ? Qt : Qnil,
+              make_int (ie->modifiers));
 
   redisplay_preserve_echo_area (35);
 }
@@ -1149,12 +1150,12 @@ These are only called if a connection to the Haiku 
display was opened.  */);
 
   DEFVAR_LISP ("haiku-drag-wheel-function", Vhaiku_drag_wheel_function,
     doc: /* Function called upon wheel movement while dragging a message.
-If non-nil, it is called with 5 arguments when the mouse wheel moves
+If non-nil, it is called with 6 arguments when the mouse wheel moves
 while a drag-and-drop operation is in progress: the frame where the
 mouse moved, the frame-relative X and Y positions where the mouse
-moved, whether or not the wheel movement was horizontal, and whether
-or not the wheel moved up (or left, if the movement was
-horizontal).  */);
+moved, whether or not the wheel movement was horizontal, whether or
+not the wheel moved up (or left, if the movement was horizontal), and
+keyboard modifiers currently held down.  */);
   Vhaiku_drag_wheel_function = Qnil;
 
   DEFSYM (QSECONDARY, "SECONDARY");