diff options
Diffstat (limited to 'lisp/x-dnd.el')
| -rw-r--r-- | lisp/x-dnd.el | 84 |
1 files changed, 61 insertions, 23 deletions
diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el index a06563946c6..bdfe444bc1d 100644 --- a/lisp/x-dnd.el +++ b/lisp/x-dnd.el @@ -194,7 +194,8 @@ any protocol specific data.") (defun x-dnd-init-frame (&optional frame) "Setup drag and drop for FRAME (i.e. create appropriate properties)." - (when (eq 'x (window-system frame)) + (when (and (eq 'x (window-system frame)) + (not (frame-parameter frame 'tooltip))) (let ((x-fast-protocol-requests (not x-dnd-debug-errors))) (x-register-dnd-atom "DndProtocol" frame) (x-register-dnd-atom "_MOTIF_DRAG_AND_DROP_MESSAGE" frame) @@ -707,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) @@ -722,15 +722,27 @@ MODS is a single symbol, or a list of symbols such as `shift' or (setq mask (nth 2 virtual-modifiers))))) mask)) -(defun x-dnd-hscroll-flags () - "Return the event state of a button press that should result in hscroll. -Value is a mask of all the X modifier states that would normally -cause a button press event to perform horizontal scrolling." - (let ((i 0)) - (dolist (modifier mouse-wheel-scroll-amount) - (when (eq (cdr-safe modifier) 'hscroll) - (setq i (logior i (x-dnd-modifier-mask (car modifier)))))) - i)) +(defun x-dnd-get-modifiers () + "Obtain an X modifier mask containing all modifiers. +Value is an X modifier mask containing all modifiers that can +modify an Emacs keyboard or mouse event." + (let ((mods (x-get-modifier-masks)) + (mask 5)) ; ShiftMask | ControlMask + (dolist (mod mods) + (setq mask (logior mask mod))) + mask)) + +(defun x-dnd-wheel-modifier-type (flags) + "Return the modifier type of an X modifier mask. +FLAGS is the X modifier mask of a turn of the mouse wheel." + (let ((modifiers (x-dnd-get-modifiers))) + (catch 'type + (dolist (modifier mouse-wheel-scroll-amount) + (when (and (consp modifier) + (eq (x-dnd-modifier-mask (car modifier)) + (logand flags modifiers))) + (throw 'type (cdr modifier)))) + nil))) (defvar x-dnd-click-count nil "Alist of button numbers to click counters during drag-and-drop. @@ -760,19 +772,23 @@ Use MODIFIERS, an X modifier mask, to determine if any alternative operation (such as scrolling horizontally) should be taken. COUNT is the number of times in quick succession BUTTON has been pressed." - (let ((hscroll (not (zerop (logand modifiers - (x-dnd-hscroll-flags))))) - (amt (or (and (not mouse-wheel-progressive-speed) 1) - (* 1 count)))) + (let* ((type (x-dnd-wheel-modifier-type modifiers)) + (hscroll (eq type 'hscroll)) + (amt (or (and (not mouse-wheel-progressive-speed) 1) + (* 1 count)))) (unless (and (not mouse-wheel-tilt-scroll) (or (eq button 6) (eq button 7))) - (let ((function (cond ((eq button 4) + (let ((function (cond ((eq type 'text-scale) + #'text-scale-adjust) + ((eq type 'global-text-scale) + #'global-text-scale-adjust) + ((eq button 4) (if hscroll - mwheel-scroll-left-function + mwheel-scroll-right-function mwheel-scroll-down-function)) ((eq button 5) (if hscroll - mwheel-scroll-right-function + mwheel-scroll-left-function mwheel-scroll-up-function)) ((eq button 6) (if mouse-wheel-flip-direction @@ -782,9 +798,17 @@ has been pressed." (if mouse-wheel-flip-direction mwheel-scroll-left-function mwheel-scroll-right-function))))) + ;; Button5 should decrease the text scale, not increase it. + (when (and (memq type '(text-scale global-text-scale)) + (eq button 5)) + (setq amt (- amt))) (when function (condition-case nil - (funcall function amt) + ;; Don't overwrite any echo-area message that might + ;; already be shown, since this can be called from + ;; `x-begin-drag'. + (let ((inhibit-message t)) + (funcall function amt)) ;; Do not error at buffer limits. Show a message instead. ;; This is especially important here because signalling an ;; error will mess up the drag-and-drop operation. @@ -1417,6 +1441,11 @@ ACTION is the action given to `x-begin-drag'." (defvar x-dnd-disable-motif-protocol) (defvar x-dnd-use-unsupported-drop) +(defvar x-dnd-xds-testing nil + "Whether or not XDS is being tested from ERT. +When non-nil, throw errors from the `XdndDirectSave0' converters +instead of returning \"E\".") + (defun x-dnd-handle-direct-save (_selection _type _value) "Handle a selection request for `XdndDirectSave'." (setq x-dnd-xds-performed t) @@ -1431,15 +1460,24 @@ ACTION is the action given to `x-begin-drag'." (dnd-get-local-file-name local-file-uri)))) (if (not local-name) '(STRING . "F") - (condition-case nil - (progn + ;; We want errors to be signalled immediately during ERT + ;; testing, instead of being silently handled. (bug#56712) + (if x-dnd-xds-testing + (prog1 '(STRING . "S") (copy-file x-dnd-xds-current-file local-name t) (when (equal x-dnd-xds-current-file dnd-last-dragged-remote-file) (dnd-remove-last-dragged-remote-file))) - (:success '(STRING . "S")) - (error '(STRING . "E")))))) + (condition-case nil + (progn + (copy-file x-dnd-xds-current-file + local-name t) + (when (equal x-dnd-xds-current-file + dnd-last-dragged-remote-file) + (dnd-remove-last-dragged-remote-file))) + (:success '(STRING . "S")) + (error '(STRING . "E"))))))) (defun x-dnd-handle-octet-stream (_selection _type _value) "Handle a selecton request for `application/octet-stream'. |