From: Po Lu Date: Tue, 26 Jul 2022 05:41:25 +0000 (+0000) Subject: Handle modifiers during Haiku DND wheel movement X-Git-Tag: emacs-29.0.90~1447^2~749 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=2bc6d8283189bcbbf9bceeac5013b9e41a511222;p=emacs.git 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. --- diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el index 9d9c31970dc..a16169d477f 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 10fd9e5dac3..bdfe444bc1d 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 268d8b1ec92..7eb93a2754d 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");