diff options
Diffstat (limited to 'lisp/x-dnd.el')
| -rw-r--r-- | lisp/x-dnd.el | 1653 |
1 files changed, 1301 insertions, 352 deletions
diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el index 559679131bd..bdfe444bc1d 100644 --- a/lisp/x-dnd.el +++ b/lisp/x-dnd.el @@ -24,8 +24,9 @@ ;;; Commentary: -;; This file provides the drop part only. Currently supported protocols -;; are XDND, Motif and the old KDE 1.x protocol. +;; This file provides the receiving side of the XDND and Motif +;; protocols, and both the receiving and initiating ends of the old +;; KDE (OffiX) and new OffiX protocols. ;;; Code: @@ -35,25 +36,26 @@ (defcustom x-dnd-test-function #'x-dnd-default-test-function "The function drag and drop uses to determine if to accept or reject a drop. The function takes three arguments, WINDOW, ACTION and TYPES. -WINDOW is where the mouse is when the function is called. WINDOW may be a -frame if the mouse isn't over a real window (i.e. menu bar, tool bar or -scroll bar). ACTION is the suggested action from the drag and drop source, -one of the symbols move, copy, link or ask. TYPES is a list of available -types for the drop. - -The function shall return nil to reject the drop or a cons with two values, -the wanted action as car and the wanted type as cdr. The wanted action -can be copy, move, link, ask or private. +WINDOW is where the mouse is when the function is called. WINDOW +may be a frame if the mouse isn't over a real window (i.e. menu +bar, tool bar or scroll bar). ACTION is the suggested action +from the drag and drop source, one of the symbols move, copy, +link or ask. TYPES is a vector of available types for the drop. + +Each element of TYPE should either be a string (containing the +name of the type's X atom), or a symbol, whose name will be used. + +The function shall return nil to reject the drop or a cons with +two values, the wanted action as car and the wanted type as cdr. +The wanted action can be copy, move, link, ask or private. + The default value for this variable is `x-dnd-default-test-function'." :version "22.1" :type 'symbol :group 'x) - - (defcustom x-dnd-types-alist - `( - (,(purecopy "text/uri-list") . x-dnd-handle-uri-list) + `((,(purecopy "text/uri-list") . x-dnd-handle-uri-list) (,(purecopy "text/x-moz-url") . x-dnd-handle-moz-url) (,(purecopy "_NETSCAPE_URL") . x-dnd-handle-uri-list) (,(purecopy "FILE_NAME") . x-dnd-handle-file-name) @@ -65,7 +67,9 @@ The default value for this variable is `x-dnd-default-test-function'." (,(purecopy "COMPOUND_TEXT") . x-dnd-insert-ctext) (,(purecopy "STRING") . dnd-insert-text) (,(purecopy "TEXT") . dnd-insert-text) - ) + (,(purecopy "DndTypeFile") . x-dnd-handle-offix-file) + (,(purecopy "DndTypeFiles") . x-dnd-handle-offix-files) + (,(purecopy "DndTypeText") . dnd-insert-text)) "Which function to call to handle a drop of that type. If the type for the drop is not present, or the function is nil, the drop is rejected. The function takes three arguments, WINDOW, ACTION @@ -80,28 +84,82 @@ if drop is successful, nil if not." (defcustom x-dnd-known-types (mapcar 'purecopy - '("text/uri-list" - "text/x-moz-url" - "_NETSCAPE_URL" - "FILE_NAME" - "UTF8_STRING" - "text/plain;charset=UTF-8" - "text/plain;charset=utf-8" - "text/unicode" - "text/plain" - "COMPOUND_TEXT" - "STRING" - "TEXT" - )) + '("XdndDirectSave0" + "text/uri-list" + "text/x-moz-url" + "_NETSCAPE_URL" + "FILE_NAME" + "UTF8_STRING" + "text/plain;charset=UTF-8" + "text/plain;charset=utf-8" + "text/unicode" + "text/plain" + "COMPOUND_TEXT" + "STRING" + "TEXT" + "DndTypeFile" + "DndTypeText")) "The types accepted by default for dropped data. The types are chosen in the order they appear in the list." :version "22.1" :type '(repeat string) - :group 'x -) + :group 'x) + +(defcustom x-dnd-use-offix-drop 'files + "If non-nil, use the OffiX protocol to drop files and text. +This allows dropping (via `dired-mouse-drag-files' or +`mouse-drag-and-drop-region-cross-program') on some old Java +applets and old KDE programs. Turning this off allows dropping +only text on some other programs such as xterm and urxvt. + +If the symbol `files', use the OffiX protocol when dropping +files, and the fallback drop method (which is used with programs +like xterm) for text." + :version "29.1" + :type '(choice (const :tag "Don't use the OffiX protocol for drag-and-drop" nil) + (const :tag "Only use the OffiX protocol to drop files" files) + (const :tag "Use the OffiX protocol for both files and text" t)) + :group 'x) + +(defcustom x-dnd-direct-save-function #'x-dnd-save-direct + "Function called when a file is dropped that Emacs must save. +It is called with two arguments: the first is either nil or t, +and the second is a string. + +If the first argument is t, the second argument is the name the +dropped file should be saved under. The function should return a +complete file name describing where the file should be saved. + +It can also return nil, which means to cancel the drop. + +If the first argument is nil, the second is the name of the file +that was dropped." + :version "29.1" + :type '(choice (const :tag "Prompt for name before saving" + x-dnd-save-direct) + (const :tag "Save and open immediately without prompting" + x-dnd-save-direct-immediately) + (function :tag "Other function")) + :group 'x) + +(defcustom x-dnd-copy-types '("chromium/x-renderer-taint") + "List of data types offered by programs that don't support `private'. +Some programs (such as Chromium) do not support +`XdndActionPrivate'. The default `x-dnd-test-function' will +always return `copy' instead, for programs offering one of the +data types in this list." + :version "29.1" + :type '(repeat string) + :group 'x) ;; Internal variables +(defvar x-dnd-debug-errors nil + "Whether or not to signal protocol errors during drag-and-drop. +This is useful for debugging errors in the DND code, but makes +drag-and-drop much slower over network connections with high +latency.") + (defvar x-dnd-current-state nil "The current state for a drop. This is an alist with one entry for each display. The value for each display @@ -115,21 +173,39 @@ the type we want for the drop, the action we want for the drop, any protocol specific data.") +(declare-function x-get-selection-internal "xselect.c" + (selection-symbol target-type &optional time-stamp terminal)) +(declare-function x-display-set-last-user-time "xfns.c") + +(defconst x-dnd-xdnd-to-action + '(("XdndActionPrivate" . private) + ("XdndActionCopy" . copy) + ("XdndActionMove" . move) + ("XdndActionLink" . link) + ("XdndActionAsk" . ask) + ("XdndActionDirectSave" . direct-save)) + "Mapping from XDND action types to Lisp symbols.") + (defvar x-dnd-empty-state [nil nil nil nil nil nil nil]) (declare-function x-register-dnd-atom "xselect.c") +(defvar x-fast-protocol-requests) + (defun x-dnd-init-frame (&optional frame) "Setup drag and drop for FRAME (i.e. create appropriate properties)." - (when (eq 'x (window-system frame)) - (x-register-dnd-atom "DndProtocol" frame) - (x-register-dnd-atom "_MOTIF_DRAG_AND_DROP_MESSAGE" frame) - (x-register-dnd-atom "XdndEnter" frame) - (x-register-dnd-atom "XdndPosition" frame) - (x-register-dnd-atom "XdndLeave" frame) - (x-register-dnd-atom "XdndDrop" frame) - (x-dnd-init-xdnd-for-frame frame) - (x-dnd-init-motif-for-frame 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) + (x-register-dnd-atom "XdndEnter" frame) + (x-register-dnd-atom "XdndPosition" frame) + (x-register-dnd-atom "XdndLeave" frame) + (x-register-dnd-atom "XdndDrop" frame) + (x-register-dnd-atom "_DND_PROTOCOL" frame) + (x-dnd-init-xdnd-for-frame frame) + (x-dnd-init-motif-for-frame frame)))) (defun x-dnd-get-state-cons-for-frame (frame-or-window) "Return the entry in `x-dnd-current-state' for a frame or window." @@ -147,14 +223,22 @@ any protocol specific data.") (defun x-dnd-default-test-function (_window _action types) "The default test function for drag and drop. -WINDOW is where the mouse is when this function is called. It may be -a frame if the mouse is over the menu bar, scroll bar or tool bar. -ACTION is the suggested action from the source, and TYPES are the -types the drop data can have. This function only accepts drops with -types in `x-dnd-known-types'. It always returns the action private." +WINDOW is where the mouse is when this function is called. It +may be a frame if the mouse is over the menu bar, scroll bar or +tool bar. ACTION is the suggested action from the source, and +TYPES are the types the drop data can have. This function only +accepts drops with types in `x-dnd-known-types'. It always +returns the action `private', unless `types' contains a value +inside `x-dnd-copy-types'." (let ((type (x-dnd-choose-type types))) - (when type (cons 'private type)))) - + (when type (let ((list x-dnd-copy-types)) + (catch 'out + (while t + (if (not list) + (throw 'out (cons 'private type)) + (if (x-dnd-find-type (car list) types) + (throw 'out (cons 'copy type)) + (setq list (cdr list)))))))))) (defun x-dnd-current-type (frame-or-window) "Return the type we want the DND data to be in for the current drop. @@ -167,29 +251,49 @@ FRAME-OR-WINDOW is the frame or window that the mouse is over." (setcdr (x-dnd-get-state-cons-for-frame frame-or-window) (copy-sequence x-dnd-empty-state))) -(defun x-dnd-maybe-call-test-function (window action) +(defun x-dnd-find-type (target types) + "Find the type TARGET in an array of types TYPES. +TARGET must be a string, but TYPES can contain either symbols or +strings." + (catch 'done + (dotimes (i (length types)) + (let* ((type (aref types i)) + (typename (if (symbolp type) + (symbol-name type) type))) + (when (equal target typename) + (throw 'done t)))) + nil)) + +(defun x-dnd-maybe-call-test-function (window action &optional xdnd) "Call `x-dnd-test-function' if something has changed. WINDOW is the window the mouse is over. ACTION is the suggested action from the source. If nothing has changed, return the last -action and type we got from `x-dnd-test-function'." +action and type we got from `x-dnd-test-function'. + +XDND means the XDND protocol is being used." (let ((buffer (when (window-live-p window) (window-buffer window))) (current-state (x-dnd-get-state-for-frame window))) - (unless (and (equal buffer (aref current-state 0)) - (equal window (aref current-state 1)) - (equal action (aref current-state 3))) - (save-current-buffer - (when buffer (set-buffer buffer)) - (let* ((action-type (funcall x-dnd-test-function - window - action - (aref current-state 2))) - (handler (cdr (assoc (cdr action-type) x-dnd-types-alist)))) - ;; Ignore action-type if we have no handler. - (setq current-state - (x-dnd-save-state window - action - (when handler action-type))))))) + (if (and xdnd (x-dnd-find-type "XdndDirectSave0" + (aref current-state 2))) + (setq current-state + (x-dnd-save-state window 'direct-save + '(direct-save . "XdndDirectSave0"))) + (unless (and (equal buffer (aref current-state 0)) + (equal window (aref current-state 1)) + (equal action (aref current-state 3))) + (save-current-buffer + (when buffer (set-buffer buffer)) + (let* ((action-type (funcall x-dnd-test-function + window + action + (aref current-state 2))) + (handler (cdr (assoc (cdr action-type) x-dnd-types-alist)))) + ;; Ignore action-type if we have no handler. + (setq current-state + (x-dnd-save-state window + action + (when handler action-type)))))))) (let ((current-state (x-dnd-get-state-for-frame window))) (cons (aref current-state 5) (aref current-state 4)))) @@ -322,7 +426,10 @@ nil if not." ;; If dropping in an ordinary window which we could use, ;; let dnd-open-file-other-window specify what to do. (progn - (when (not mouse-yank-at-point) + (when (and (not mouse-yank-at-point) + ;; If dropping on top of the mode line, insert + ;; the text at point instead. + (posn-point (event-start event))) (goto-char (posn-point (event-start event)))) (funcall handler window action data)) ;; If we can't display the file here, @@ -336,51 +443,153 @@ nil if not." Currently XDND, Motif and old KDE 1.x protocols are recognized." (interactive "e") (let* ((client-message (car (cdr (cdr event)))) - (window (posn-window (event-start event))) - (message-atom (aref client-message 0)) - (frame (aref client-message 1)) - (format (aref client-message 2)) - (data (aref client-message 3))) - - (cond ((equal "DndProtocol" message-atom) ; Old KDE 1.x. - (x-dnd-handle-old-kde event frame window message-atom format data)) - - ((equal "_MOTIF_DRAG_AND_DROP_MESSAGE" message-atom) ; Motif - (x-dnd-handle-motif event frame window message-atom format data)) - - ((and (> (length message-atom) 4) ; XDND protocol. - (equal "Xdnd" (substring message-atom 0 4))) - (x-dnd-handle-xdnd event frame window message-atom format data))))) + (x-fast-protocol-requests (not x-dnd-debug-errors)) + (window (posn-window (event-start event)))) + (if (eq (and (consp client-message) + (car client-message)) + 'XdndSelection) + ;; This is an internal Emacs message caused by something being + ;; dropped on top of a frame. + (progn + (let ((action (cdr (assoc (symbol-name (cadr client-message)) + x-dnd-xdnd-to-action))) + (targets (cddr client-message)) + (local-value (nth 2 client-message))) + (when (windowp window) + (select-window window)) + (x-dnd-save-state window nil nil + (apply #'vector targets)) + (x-dnd-maybe-call-test-function window action) + (unwind-protect + (x-dnd-drop-data event (if (framep window) window + (window-frame window)) + window + (x-get-local-selection + local-value + (intern (x-dnd-current-type window))) + (x-dnd-current-type window)) + (x-dnd-forget-drop window)))) + (let ((message-atom (aref client-message 0)) + (frame (aref client-message 1)) + (format (aref client-message 2)) + (data (aref client-message 3))) + (cond ((equal "DndProtocol" message-atom) ; Old KDE 1.x. + (x-dnd-handle-old-kde event frame window message-atom format data)) + ((equal "_DND_PROTOCOL" message-atom) ; OffiX protocol. + (x-dnd-handle-offix event frame window message-atom format data)) + ((equal "_MOTIF_DRAG_AND_DROP_MESSAGE" message-atom) ; Motif + (x-dnd-handle-motif event frame window message-atom format data)) + + ((and (> (length message-atom) 4) ; XDND protocol. + (equal "Xdnd" (substring message-atom 0 4))) + (x-dnd-handle-xdnd event frame window message-atom format data))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Old KDE protocol. Only dropping of files. +;;; Old KDE protocol. (declare-function x-window-property "xfns.c" (prop &optional frame type source delete-p vector-ret-p)) -(defun x-dnd-handle-old-kde (_event frame window _message _format _data) - "Open the files in a KDE 1.x drop." - (let ((values (x-window-property "DndSelection" frame nil 0 t))) - (x-dnd-handle-uri-list window 'private - (replace-regexp-in-string "\0$" "" values)))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - +(defvar x-dnd-offix-old-kde-to-name '((-1 . DndTypeInvalid) + (0 . DndTypeUnknown) + (1 . DndTypeRawData) + (2 . DndTypeFile) + (3 . DndTypeFiles) + (4 . DndTypeText) + (5 . DndTypeDir) + (6 . DndTypeLink) + (7 . DndTypeExe) + (8 . DndTypeUrl)) + "Alist of old KDE data types to their names.") + +(defun x-dnd-handle-old-kde (event frame window _message _format data) + "Handle an old KDE (OffiX) drop. +EVENT, FRAME, WINDOW and DATA mean the same thing they do in +`x-dnd-handle-offix.'" + (let ((proto (aref data 4))) + ;; If PROTO > 0, this is an old KDE drop emulated by a program + ;; supporting a newer version of the OffiX protocol, so we should + ;; wait for the corresponding modern event instead. + (when (zerop proto) + (let ((type (cdr (assq (aref data 0) x-dnd-offix-old-kde-to-name))) + (data (x-window-property "DndSelection" frame nil 0 t))) + ;; First save state. + (x-dnd-save-state window nil nil (vector type) nil) + ;; Now call the test function to decide what action to perform. + (x-dnd-maybe-call-test-function window 'private) + (unwind-protect + (when (windowp window) + (select-window window)) + (x-dnd-drop-data event frame window data + (symbol-name type)) + (x-dnd-forget-drop window)))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; New OffiX protocol. + +(defvar x-dnd-offix-id-to-name '((-1 . DndTypeInvalid) + (0 . DndTypeUnknown) + (1 . DndTypeRawData) + (2 . DndTypeFile) + (3 . DndTypeFiles) + (4 . DndTypeText) + (5 . DndTypeDir) + (6 . DndTypeLink) + (7 . DndTypeExe) + (8 . DndTypeUrl) + (9 . DndTypeMime) + (10 . DndTypePixmap)) + "Alist of OffiX data types to their names.") + +(defun x-dnd-handle-offix-file (window action string) + "Convert OffiX file name to a regular file name. +Then, call `x-dnd-handle-file-name'. + +WINDOW and ACTION mean the same as in `x-dnd-handle-file-name'. +STRING is the raw OffiX file name data." + (x-dnd-handle-file-name window action + (replace-regexp-in-string "\0$" "" string))) + +(defun x-dnd-handle-offix-files (window action string) + "Convert OffiX file name list to a URI list. +Then, call `x-dnd-handle-file-name'. + +WINDOW and ACTION mean the same as in `x-dnd-handle-file-name'. +STRING is the raw OffiX file name data." + (x-dnd-handle-file-name window action + ;; OffiX file name lists contain one extra + ;; NULL byte at the end. + (if (string-suffix-p "\0\0" string) + (substring string 0 (1- (length string))) + string))) + +(defun x-dnd-handle-offix (event frame window _message-atom _format data) + "Handle OffiX drop event EVENT. +FRAME is the frame where the drop happened. +WINDOW is the window where the drop happened. +_MESSAGE-ATOM and _FORMAT are unused. +DATA is the vector containing the contents of the client +message (format 32) that caused EVENT to be generated." + (let ((type (cdr (assq (aref data 0) x-dnd-offix-id-to-name))) + (data (x-window-property "_DND_SELECTION" frame nil 0 t))) + ;; First save state. + (x-dnd-save-state window nil nil (vector type) nil) + ;; Now call the test function to decide what action to perform. + (x-dnd-maybe-call-test-function window 'private) + (unwind-protect + (when (windowp window) + (select-window window)) + (x-dnd-drop-data event frame window data + (symbol-name type)) + (x-dnd-forget-drop window)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; XDND protocol. -(defconst x-dnd-xdnd-to-action - '(("XdndActionPrivate" . private) - ("XdndActionCopy" . copy) - ("XdndActionMove" . move) - ("XdndActionLink" . link) - ("XdndActionAsk" . ask)) - "Mapping from XDND action types to Lisp symbols.") - (declare-function x-change-window-property "xfns.c" - (prop value &optional frame type format outer-P)) + (prop value &optional frame type format outer-P window-id)) +(declare-function x-translate-coordinates "xfns.c") (defun x-dnd-init-xdnd-for-frame (frame) "Set the XdndAware property for FRAME to indicate that we do XDND." @@ -388,45 +597,97 @@ Currently XDND, Motif and old KDE 1.x protocols are recognized." '(5) ;; The version of XDND we support. frame "ATOM" 32 t)) -(defun x-dnd-get-drop-width-height (frame w accept) - "Return the width/height to be sent in a XDndStatus message. -FRAME is the frame and W is the window where the drop happened. -If ACCEPT is nil return 0 (empty rectangle), -otherwise if W is a window, return its width/height, -otherwise return the frame width/height." - (if accept - (if (windowp w) ;; w is not a window if dropping on the menu bar, - ;; scroll bar or tool bar. - (let ((edges (window-inside-pixel-edges w))) - (cons - (- (nth 2 edges) (nth 0 edges)) ;; right - left - (- (nth 3 edges) (nth 1 edges)))) ;; bottom - top - (cons (frame-pixel-width frame) - (frame-pixel-height frame))) - 0)) - -(defun x-dnd-get-drop-x-y (frame w) - "Return the x/y coordinates to be sent in a XDndStatus message. -Coordinates are required to be absolute. -FRAME is the frame and W is the window where the drop happened. -If W is a window, return its absolute coordinates, -otherwise return the frame coordinates." - (let* ((frame-left (or (car-safe (cdr-safe (frame-parameter frame 'left))) - (frame-parameter frame 'left))) - (frame-top (or (car-safe (cdr-safe (frame-parameter frame 'top))) - (frame-parameter frame 'top)))) - (if (windowp w) - (let ((edges (window-inside-pixel-edges w))) - (cons - (+ frame-left (nth 0 edges)) - (+ frame-top (nth 1 edges)))) - (cons frame-left frame-top)))) +(defun x-dnd-after-move-frame (frame) + "Handle FRAME moving to a different position. +Clear any cached root window position." + (set-frame-parameter frame 'dnd-root-window-position + nil)) + +(add-hook 'move-frame-functions #'x-dnd-after-move-frame) + +(defun x-dnd-compute-root-window-position (frame) + "Return the position of FRAME's edit widget relative to the root window. +The value is a cons of (X . Y), describing the position of +FRAME's edit widget (inner window) relative to the root window of +its screen." + (or (frame-parameter frame 'dnd-root-window-position) + (let* ((result (x-translate-coordinates frame)) + (param (cons (car result) (cadr result)))) + (unless result + (error "Frame isn't on the same screen as its root window")) + (prog1 param + (set-frame-parameter frame 'dnd-root-window-position param))))) + +(defun x-dnd-get-window-rectangle (window) + "Return the bounds of WINDOW as a rectangle. +The coordinates in the rectangle are relative to its frame's root +window. Return the bounds as a list of (X Y WIDTH HEIGHT)." + (let* ((frame (window-frame window)) + (frame-pos (x-dnd-compute-root-window-position frame)) + (edges (window-inside-pixel-edges window))) + (list (+ (car frame-pos) (nth 0 edges)) + (+ (cdr frame-pos) (nth 1 edges)) + (- (nth 2 edges) (nth 0 edges)) + (- (nth 3 edges) (nth 1 edges))))) + +(defun x-dnd-intersect-rectangles (r1 r2) + "Return the intersection of R1 and R2, both rectangles." + (let ((left (if (< (car r1) (car r2)) r1 r2)) + (right (if (> (car r2) (car r1)) r2 r1)) + (upper (if (< (cadr r1) (cadr r2)) r1 r2)) + (lower (if (> (cadr r2) (cadr r1)) r2 r1)) + (result (list 0 0 0 0))) + (when (<= (car right) (+ (car left) (nth 2 left))) + (setcar result (car right)) + (setcar (nthcdr 2 result) + (- (min (+ (car left) (nth 2 left)) + (+ (car right) (nth 2 right))) + (car result))) + (when (<= (cadr lower) (+ (cadr upper) (nth 3 upper))) + (setcar (cdr result) (cadr lower)) + (setcar (nthcdr 3 result) + (- (min (+ (cadr lower) (nth 3 lower)) + (+ (cadr upper) (nth 3 upper))) + (cadr result))))) + result)) + +(defun x-dnd-get-object-rectangle (window posn) + "Return the rectangle of the object (character or image) under POSN. +WINDOW is the window POSN represents. The rectangle is returned +with coordinates relative to the root window." + (if (posn-point posn) + (with-selected-window window + (if-let* ((new-posn (posn-at-point (posn-point posn))) + (posn-x-y (posn-x-y new-posn)) + (object-width-height (posn-object-width-height new-posn)) + (edges (window-inside-pixel-edges window)) + (frame-pos (x-dnd-compute-root-window-position + (window-frame window)))) + (list (+ (car frame-pos) (car posn-x-y) + (car edges)) + (+ (cdr frame-pos) (cdr posn-x-y) + (cadr edges)) + (car object-width-height) + (cdr object-width-height)) + '(0 0 0 0))) + '(0 0 0 0))) + +(defun x-dnd-get-drop-rectangle (window posn) + "Return the drag-and-drop rectangle at POSN on WINDOW." + (if (or dnd-scroll-margin + (not (windowp window))) + '(0 0 0 0) + (let ((window-rectangle (x-dnd-get-window-rectangle window)) + object-rectangle) + (when dnd-indicate-insertion-point + (setq object-rectangle (x-dnd-get-object-rectangle window posn) + window-rectangle (x-dnd-intersect-rectangles object-rectangle + window-rectangle))) + window-rectangle))) (declare-function x-get-atom-name "xselect.c" (value &optional frame)) (declare-function x-send-client-message "xselect.c" (display dest from message-type format values)) -(declare-function x-get-selection-internal "xselect.c" - (selection-symbol target-type &optional time-stamp terminal)) (defun x-dnd-version-from-flags (flags) "Return the version byte from the 32 bit FLAGS in an XDndEnter message." @@ -436,82 +697,263 @@ otherwise return the frame coordinates." "Return the nmore-than3 bit from the 32 bit FLAGS in an XDndEnter message." (logand flags 1)) +(declare-function x-get-modifier-masks "xfns.c") + +(defun x-dnd-modifier-mask (mods) + "Return the X modifier mask for the Emacs modifier state MODS. +MODS is a single symbol, or a list of symbols such as `shift' or +`control'." + (let ((virtual-modifiers (x-get-modifier-masks)) + (mask 0)) + (unless (consp mods) + (setq mods (list mods))) + (dolist (modifier mods) + (cond ((eq modifier 'shift) + (setq mask (logior mask 1))) ; ShiftMask + ((eq modifier 'control) + (setq mask (logior mask 4))) ; ControlMask + ((eq modifier 'meta) + (setq mask (logior mask (nth 4 virtual-modifiers)))) + ((eq modifier 'hyper) + (setq mask (car virtual-modifiers))) + ((eq modifier 'super) + (setq mask (cadr virtual-modifiers))) + ((eq modifier 'alt) + (setq mask (nth 2 virtual-modifiers))))) + mask)) + +(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. +The cdr of each association's cdr is the timestamp of the last +button press event for the given button, and the car is the +number of clicks in quick succession currently received.") + +(defun x-dnd-note-click (button timestamp) + "Note that button BUTTON was pressed at TIMESTAMP during drag-and-drop. +Return the number of clicks that were made in quick succession." + (if (not (integerp double-click-time)) + 1 + (let ((cell (cdr (assq button x-dnd-click-count)))) + (unless cell + (setq cell (cons 0 timestamp)) + (push (cons button cell) + x-dnd-click-count)) + (when (< (cdr cell) (- timestamp double-click-time)) + (setcar cell 0)) + (setcar cell (1+ (car cell))) + (setcdr cell timestamp) + (car cell)))) + +(defun x-dnd-mwheel-scroll (button count modifiers) + "Call the appropriate wheel scrolling function for BUTTON. +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* ((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 type 'text-scale) + #'text-scale-adjust) + ((eq type 'global-text-scale) + #'global-text-scale-adjust) + ((eq button 4) + (if hscroll + mwheel-scroll-right-function + mwheel-scroll-down-function)) + ((eq button 5) + (if hscroll + mwheel-scroll-left-function + mwheel-scroll-up-function)) + ((eq button 6) + (if mouse-wheel-flip-direction + mwheel-scroll-right-function + mwheel-scroll-left-function)) + ((eq button 7) + (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 + ;; 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. + (beginning-of-buffer + (message (error-message-string '(beginning-of-buffer)))) + (end-of-buffer + (message (error-message-string '(end-of-buffer)))))))))) + (defun x-dnd-handle-xdnd (event frame window message _format data) "Receive one XDND event (client message) and send the appropriate reply. EVENT is the client message. FRAME is where the mouse is now. WINDOW is the window within FRAME where the mouse is now. -FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent." +DATA is the vector containing the data of the client message as a +vector of cardinals. +MESSAGE is the type of the ClientMessage that was sent." (cond ((equal "XdndEnter" message) (let* ((flags (aref data 1)) (version (x-dnd-version-from-flags flags)) (more-than-3 (x-dnd-more-than-3-from-flags flags)) (dnd-source (aref data 0))) - (message "%s %s" version more-than-3) - (if version ;; If flags is bad, version will be nil. - (x-dnd-save-state - window nil nil - (if (> more-than-3 0) - (x-window-property "XdndTypeList" - frame "AnyPropertyType" - dnd-source nil t) - (vector (x-get-atom-name (aref data 2)) - (x-get-atom-name (aref data 3)) - (x-get-atom-name (aref data 4)))))))) + (when version ;; If flags is bad, version will be nil. + (x-dnd-save-state + window nil nil + (if (> more-than-3 0) + (x-window-property "XdndTypeList" + frame "AnyPropertyType" + dnd-source nil t) + (vector (x-get-atom-name (aref data 2)) + (x-get-atom-name (aref data 3)) + (x-get-atom-name (aref data 4)))) + version)))) ((equal "XdndPosition" message) - (let* ((action (x-get-atom-name (aref data 4))) - (dnd-source (aref data 0)) - (action-type (x-dnd-maybe-call-test-function - window - (cdr (assoc action x-dnd-xdnd-to-action)))) - (reply-action (car (rassoc (car action-type) - x-dnd-xdnd-to-action))) - (accept ;; 1 = accept, 0 = reject - (if (and reply-action action-type) 1 0)) - (list-to-send - (list (string-to-number - (frame-parameter frame 'outer-window-id)) - accept ;; 1 = Accept, 0 = reject. - (x-dnd-get-drop-x-y frame window) - (x-dnd-get-drop-width-height - frame window (eq accept 1)) - (or reply-action 0) - ))) - (x-send-client-message - frame dnd-source frame "XdndStatus" 32 list-to-send) - )) + ;; If (flags >> 10) & 1, then Emacs should scroll according + ;; to the button passed in bits 8 and 9, and the state passed + ;; in bits 0 to 7. + (let ((state (x-dnd-get-state-for-frame window))) + (when (windowp (posn-window (event-start event))) + (let ((flags (aref data 1)) + (version (aref state 6))) + (when (not (zerop (logand (ash flags -10) 1))) + (let* ((button (+ 4 (logand (ash flags -8) #x3))) + (count (or (and (>= version 1) + (x-dnd-note-click button + (aref data 3))) + 1)) + (state (logand flags #xff))) + (with-selected-window (posn-window (event-start event)) + (x-dnd-mwheel-scroll button count state) + (let ((old-x-y (posn-x-y (event-start event)))) + (setcar (cdr event) + (posn-at-x-y (max (car old-x-y) 0) + (max (cdr old-x-y) 0))))))))) + (let* ((version (aref state 6)) + (action (if (< version 2) 'copy ; `copy' is the default action. + (x-get-atom-name (aref data 4)))) + (dnd-source (aref data 0)) + (action-type (x-dnd-maybe-call-test-function + window + (cdr (assoc action x-dnd-xdnd-to-action)) t)) + (reply-action (car (rassoc + ;; Mozilla and some other programs + ;; support XDS, but only if we + ;; reply with `copy'. We can + ;; recognize these broken programs + ;; by checking to see if + ;; `XdndActionDirectSave' was + ;; originally specified. + (if (and (eq (car action-type) + 'direct-save) + (not (eq action 'direct-save))) + 'copy + (car action-type)) + x-dnd-xdnd-to-action))) + (accept ;; 1 = accept, 0 = reject + (if (and reply-action action-type + ;; Only allow drops on the text area of a + ;; window. + (not (posn-area (event-start event)))) + 1 0)) + (rect (x-dnd-get-drop-rectangle window + (event-start event))) + (list-to-send + (list (string-to-number + (frame-parameter frame 'outer-window-id)) + ;; 1 = accept, 0 = reject. 2 = "want position + ;; updates even for movement inside the given + ;; widget bounds". + accept + (cons (car rect) (cadr rect)) + (cons (nth 2 rect) (nth 3 rect)) + ;; The no-toolkit Emacs build can actually + ;; receive drops from programs that speak + ;; versions of XDND earlier than 3 (such as + ;; GNUstep), since the toplevel window is the + ;; innermost window. + (if (>= version 2) + (or reply-action 0) + 0)))) + (x-send-client-message + frame dnd-source frame "XdndStatus" 32 list-to-send) + (dnd-handle-movement (event-start event))))) ((equal "XdndLeave" message) (x-dnd-forget-drop window)) ((equal "XdndDrop" message) (if (windowp window) (select-window window)) - (let* ((dnd-source (aref data 0)) + (let* ((state (x-dnd-get-state-for-frame frame)) + (version (aref state 6)) + (dnd-source (aref data 0)) (timestamp (aref data 2)) - (value (and (x-dnd-current-type window) - (x-get-selection-internal - 'XdndSelection - (intern (x-dnd-current-type window)) - timestamp))) - success action) - - (setq action (if value - (condition-case info - (x-dnd-drop-data event frame window value - (x-dnd-current-type window)) - (error - (message "Error: %s" info) - nil)))) - - (setq success (if action 1 0)) - - (x-send-client-message - frame dnd-source frame "XdndFinished" 32 - (list (string-to-number (frame-parameter frame 'outer-window-id)) - success ;; 1 = Success, 0 = Error - (if success "XdndActionPrivate" 0) - )) - (x-dnd-forget-drop window))) + (current-action (aref state 5)) + (current-type (aref state 4)) + success action value) + (x-display-set-last-user-time timestamp) + (if (and (eq current-action 'direct-save) + (equal current-type "XdndDirectSave0")) + (x-dnd-handle-xds-drop event window dnd-source version) + (setq value (and (x-dnd-current-type window) + (x-get-selection-internal + 'XdndSelection + (intern (x-dnd-current-type window)) + timestamp))) + (unwind-protect + (setq action (if value + (condition-case info + (x-dnd-drop-data + event frame window value + (x-dnd-current-type window)) + (error + (message "Error: %s" info) + nil)))) + (setq success (if action 1 0)) + (when (>= version 2) + (x-send-client-message + frame dnd-source frame "XdndFinished" 32 + (list (string-to-number + (frame-parameter frame 'outer-window-id)) + (if (>= version 5) success 0) ;; 1 = Success, 0 = Error + (if (or (not action) (< version 5)) 0 + (or (car (rassoc action + x-dnd-xdnd-to-action)) + 0))))) + (x-dnd-forget-drop window))))) (t (error "Unknown XDND message %s %s" message data)))) @@ -562,6 +1004,88 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent." (reverse bytes) bytes))) +(defun x-dnd-xm-unpack-targets-table-header (data) + "Decode the header of DATA, a Motif targets table. +Return a list of the following fields with the given types: + + Field name Type + - BYTE_ORDER BYTE + - PROTOCOL BYTE + - TARGET_LIST_COUNT CARD16 + - TOTAL_DATA_SIZE CARD32" + (let* ((byte-order (aref data 0)) + (protocol (aref data 1)) + (target-list-count (x-dnd-get-motif-value + data 2 2 byte-order)) + (total-data-size (x-dnd-get-motif-value + data 4 4 byte-order))) + (list byte-order protocol target-list-count + total-data-size))) + +(defun x-dnd-xm-read-single-rec (data i) + "Read a single rec from DATA, a Motif targets table. +I is the offset into DATA to begin reading at. Return a list +of (CONSUMED NTARGETS TARGETS), where CONSUMED is the number of +bytes read from DATA, NTARGETS is the total number of targets +inside the current rec, and TARGETS is a vector of atoms +describing the selection targets in the current rec." + (let* ((byte-order (aref data 0)) + (n-targets (x-dnd-get-motif-value + data i 2 byte-order)) + (targets (make-vector n-targets nil)) + (consumed 0)) + (while (< consumed n-targets) + (aset targets consumed (x-dnd-get-motif-value + data (+ i 2 (* consumed 4)) + 4 byte-order)) + (setq consumed (1+ consumed))) + (list (+ 2 (* consumed 4)) n-targets targets))) + +(defun x-dnd-xm-read-targets-table (frame) + "Read the Motif targets table on FRAME. +Return a vector of vectors of numbers, which are the atoms of the +available selection targets for each index into the selection +table." + (let* ((drag-window (x-window-property "_MOTIF_DRAG_WINDOW" + frame "WINDOW" 0 nil t)) + (targets-data (x-window-property "_MOTIF_DRAG_TARGETS" + frame "_MOTIF_DRAG_TARGETS" + drag-window nil t)) + (header (x-dnd-xm-unpack-targets-table-header targets-data)) + (vec (make-vector (nth 2 header) nil)) + (current-byte 8) + (i 0)) + (unless (stringp targets-data) + (error "Expected format 8, got %s" (type-of targets-data))) + (prog1 vec + (while (< i (nth 2 header)) + (let ((rec (x-dnd-xm-read-single-rec targets-data + current-byte))) + (aset vec i (nth 2 rec)) + (setq current-byte (+ current-byte (car rec))) + (setq i (1+ i)))) + (unless (eq current-byte (nth 3 header)) + (error "Targets table header says size is %d, but it is actually %d" + (nth 3 header) current-byte))))) + +(defun x-dnd-xm-read-targets (frame window selection) + "Read targets of SELECTION on FRAME from the targets table. +WINDOW should be the drag-and-drop operation's initiator. +Return a vector of atoms containing the selection targets." + (let* ((targets-table (x-dnd-xm-read-targets-table frame)) + (initiator-info (x-window-property selection frame + "_MOTIF_DRAG_INITIATOR_INFO" + window nil nil)) + (byte-order (aref initiator-info 0)) + (idx (x-dnd-get-motif-value initiator-info + 2 2 byte-order)) + (vector (aref targets-table idx)) + (i 0)) + (prog1 vector + (while (< i (length vector)) + (aset vector i + (intern (x-get-atom-name (aref vector i)))) + (setq i (1+ i)))))) (defvar x-dnd-motif-message-types '((0 . XmTOP_LEVEL_ENTER) @@ -583,178 +1107,603 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent." (2 . private)) ; Motif does not have private, so use copy for private. "Mapping from number to operation for Motif DND.") -(defun x-dnd-handle-motif (event frame window message-atom _format data) - (let* ((message-type (cdr (assoc (aref data 0) x-dnd-motif-message-types))) +(defun x-dnd-handle-motif (event frame window _message-atom _format data) + (let* ((message-type (cdr (assoc (logand (aref data 0) #x3f) + x-dnd-motif-message-types))) + (initiator-p (eq (ash (aref data 0) -7) 0)) (source-byteorder (aref data 1)) (my-byteorder (byteorder)) (source-flags (x-dnd-get-motif-value data 2 2 source-byteorder)) (source-action (cdr (assoc (logand ?\xF source-flags) x-dnd-motif-to-action)))) - (cond ((eq message-type 'XmTOP_LEVEL_ENTER) - (let* ((dnd-source (x-dnd-get-motif-value - data 8 4 source-byteorder)) - (selection-atom (x-dnd-get-motif-value - data 12 4 source-byteorder)) - (atom-name (x-get-atom-name selection-atom)) - (types (when atom-name - (x-get-selection-internal (intern atom-name) - 'TARGETS)))) - (x-dnd-forget-drop frame) - (when types (x-dnd-save-state window nil nil - types - dnd-source)))) - - ;; Can not forget drop here, LEAVE comes before DROP_START and - ;; we need the state in DROP_START. - ((eq message-type 'XmTOP_LEVEL_LEAVE) - nil) - - ((eq message-type 'XmDRAG_MOTION) - (let* ((state (x-dnd-get-state-for-frame frame)) - (timestamp (x-dnd-motif-value-to-list - (x-dnd-get-motif-value data 4 4 - source-byteorder) - 4 my-byteorder)) - (x (x-dnd-motif-value-to-list - (x-dnd-get-motif-value data 8 2 source-byteorder) - 2 my-byteorder)) - (y (x-dnd-motif-value-to-list - (x-dnd-get-motif-value data 10 2 source-byteorder) - 2 my-byteorder)) - (dnd-source (aref state 6)) - (first-move (not (aref state 3))) - (action-type (x-dnd-maybe-call-test-function - window - source-action)) - (reply-action (car (rassoc (car action-type) - x-dnd-motif-to-action))) - (reply-flags - (x-dnd-motif-value-to-list - (if reply-action - (+ reply-action - ?\x30 ; 30: valid drop site - ?\x700) ; 700: can do copy, move or link - ?\x30) ; 30: drop site, but noop. - 2 my-byteorder)) - (reply (append - (list - (+ ?\x80 ; 0x80 indicates a reply. - (if first-move - 3 ; First time, reply is SITE_ENTER. - 2)) ; Not first time, reply is DRAG_MOTION. - my-byteorder) - reply-flags - timestamp - x - y))) - (x-send-client-message frame - dnd-source - frame - "_MOTIF_DRAG_AND_DROP_MESSAGE" - 8 - reply))) - - ((eq message-type 'XmOPERATION_CHANGED) - (let* ((state (x-dnd-get-state-for-frame frame)) - (timestamp (x-dnd-motif-value-to-list - (x-dnd-get-motif-value data 4 4 source-byteorder) - 4 my-byteorder)) - (dnd-source (aref state 6)) - (action-type (x-dnd-maybe-call-test-function - window - source-action)) - (reply-action (car (rassoc (car action-type) - x-dnd-motif-to-action))) - (reply-flags - (x-dnd-motif-value-to-list - (if reply-action - (+ reply-action - ?\x30 ; 30: valid drop site - ?\x700) ; 700: can do copy, move or link - ?\x30) ; 30: drop site, but noop - 2 my-byteorder)) - (reply (append - (list - (+ ?\x80 ; 0x80 indicates a reply. - 8) ; 8 is OPERATION_CHANGED - my-byteorder) - reply-flags - timestamp))) - (x-send-client-message frame - dnd-source - frame - "_MOTIF_DRAG_AND_DROP_MESSAGE" - 8 - reply))) - - ((eq message-type 'XmDROP_START) - (let* ((x (x-dnd-motif-value-to-list - (x-dnd-get-motif-value data 8 2 source-byteorder) - 2 my-byteorder)) - (y (x-dnd-motif-value-to-list - (x-dnd-get-motif-value data 10 2 source-byteorder) - 2 my-byteorder)) - (selection-atom (x-dnd-get-motif-value - data 12 4 source-byteorder)) - (atom-name (x-get-atom-name selection-atom)) - (dnd-source (x-dnd-get-motif-value - data 16 4 source-byteorder)) - (action-type (x-dnd-maybe-call-test-function - window - source-action)) - (reply-action (car (rassoc (car action-type) - x-dnd-motif-to-action))) - (reply-flags - (x-dnd-motif-value-to-list - (if reply-action - (+ reply-action - ?\x30 ; 30: valid drop site - ?\x700) ; 700: can do copy, move or link - (+ ?\x30 ; 30: drop site, but noop. - ?\x200)) ; 200: drop cancel. - 2 my-byteorder)) - (reply (append - (list - (+ ?\x80 ; 0x80 indicates a reply. - 5) ; DROP_START. - my-byteorder) - reply-flags - x - y)) - (timestamp (x-dnd-get-motif-value - data 4 4 source-byteorder)) - action) - - (x-send-client-message frame - dnd-source - frame - "_MOTIF_DRAG_AND_DROP_MESSAGE" - 8 - reply) - (setq action - (when (and reply-action atom-name) - (let* ((value (x-get-selection-internal - (intern atom-name) - (intern (x-dnd-current-type window))))) - (when value - (condition-case info - (x-dnd-drop-data event frame window value - (x-dnd-current-type window)) - (error - (message "Error: %s" info) - nil)))))) - (x-get-selection-internal - (intern atom-name) - (if action 'XmTRANSFER_SUCCESS 'XmTRANSFER_FAILURE) - timestamp) - (x-dnd-forget-drop frame))) - - (t (error "Unknown Motif DND message %s %s" message-atom data))))) + (when initiator-p + (cond ((eq message-type 'XmTOP_LEVEL_ENTER) + (let* ((dnd-source (x-dnd-get-motif-value + data 8 4 source-byteorder)) + (selection-atom (x-dnd-get-motif-value + data 12 4 source-byteorder)) + (atom-name (x-get-atom-name selection-atom)) + (types (x-dnd-xm-read-targets frame dnd-source + atom-name))) + (x-dnd-forget-drop frame) + (when types (x-dnd-save-state window nil nil + types dnd-source)))) + + ;; Can not forget drop here, LEAVE comes before DROP_START and + ;; we need the state in DROP_START. + ((eq message-type 'XmTOP_LEVEL_LEAVE) + nil) + + ((eq message-type 'XmDRAG_MOTION) + (let* ((state (x-dnd-get-state-for-frame frame)) + (timestamp (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 4 4 + source-byteorder) + 4 my-byteorder)) + (x (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 8 2 source-byteorder) + 2 my-byteorder)) + (y (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 10 2 source-byteorder) + 2 my-byteorder)) + (dnd-source (aref state 6)) + (first-move (not (aref state 3))) + (action-type (x-dnd-maybe-call-test-function + window + source-action)) + (reply-action (car (rassoc (car action-type) + x-dnd-motif-to-action))) + (reply-flags + (if (posn-area (event-start event)) + (x-dnd-motif-value-to-list ?\x20 ; 20: invalid drop site + 2 my-byteorder) + (x-dnd-motif-value-to-list + (if reply-action + (+ reply-action + ?\x30 ; 30: valid drop site + ?\x700) ; 700: can do copy, move or link + ?\x30) ; 30: drop site, but noop. + 2 my-byteorder))) + (reply (append + (list + (+ ?\x80 ; 0x80 indicates a reply. + (if first-move + 3 ; First time, reply is SITE_ENTER. + 2)) ; Not first time, reply is DRAG_MOTION. + my-byteorder) + reply-flags + timestamp + x + y))) + (x-display-set-last-user-time timestamp) + (x-send-client-message frame + dnd-source + frame + "_MOTIF_DRAG_AND_DROP_MESSAGE" + 8 + reply) + (dnd-handle-movement (event-start event)))) + + ((eq message-type 'XmOPERATION_CHANGED) + (let* ((state (x-dnd-get-state-for-frame frame)) + (timestamp (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 4 4 source-byteorder) + 4 my-byteorder)) + (dnd-source (aref state 6)) + (action-type (x-dnd-maybe-call-test-function + window + source-action)) + (reply-action (car (rassoc (car action-type) + x-dnd-motif-to-action))) + (reply-flags + (if (posn-area (event-start event)) + (x-dnd-motif-value-to-list ?\x20 ; 20: invalid drop site + 2 my-byteorder) + (x-dnd-motif-value-to-list + (if reply-action + (+ reply-action + ?\x30 ; 30: valid drop site + ?\x700) ; 700: can do copy, move or link + ?\x30) ; 30: drop site, but noop. + 2 my-byteorder))) + (reply (append + (list + (+ ?\x80 ; 0x80 indicates a reply. + 8) ; 8 is OPERATION_CHANGED + my-byteorder) + reply-flags + timestamp))) + (x-display-set-last-user-time timestamp) + (x-send-client-message frame + dnd-source + frame + "_MOTIF_DRAG_AND_DROP_MESSAGE" + 8 + reply))) + + ((eq message-type 'XmDROP_START) + (when (windowp window) + (select-window window)) + (let* ((x (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 8 2 source-byteorder) + 2 my-byteorder)) + (y (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 10 2 source-byteorder) + 2 my-byteorder)) + (selection-atom (x-dnd-get-motif-value + data 12 4 source-byteorder)) + (atom-name (x-get-atom-name selection-atom)) + (dnd-source (x-dnd-get-motif-value + data 16 4 source-byteorder))) + + ;; This might be a drop from a program that doesn't use + ;; the Motif drag protocol. Compute all the necessary + ;; state here if that is true. + (unless (and (x-dnd-get-state-for-frame frame) + (aref (x-dnd-get-state-for-frame frame) 2)) + (x-dnd-forget-drop frame) + (let ((types (x-dnd-xm-read-targets frame dnd-source + atom-name))) + (x-dnd-save-state window nil nil types dnd-source))) + + (let* ((action-type (x-dnd-maybe-call-test-function + window + source-action)) + (reply-action (and (not (posn-area (event-start event))) + (car (rassoc (car action-type) + x-dnd-motif-to-action)))) + (reply-flags + (x-dnd-motif-value-to-list + (if (posn-area (event-start event)) + (+ ?\x20 ; 20: invalid drop site + ?\x200) ; 200: drop cancel + (if reply-action + (+ reply-action + ?\x30 ; 30: valid drop site + ?\x700) ; 700: can do copy, move or link + (+ ?\x30 ; 30: drop site, but noop. + ?\x200))) ; 200: drop cancel. + 2 my-byteorder)) + (reply (append + (list + (+ ?\x80 ; 0x80 indicates a reply. + 5) ; DROP_START. + my-byteorder) + reply-flags + x y)) + (timestamp (x-dnd-get-motif-value + data 4 4 source-byteorder)) + action) + (x-display-set-last-user-time timestamp) + (x-send-client-message frame + dnd-source + frame + "_MOTIF_DRAG_AND_DROP_MESSAGE" + 8 + reply) + (unwind-protect + (setq action + (when (and reply-action atom-name) + (let* ((value (x-get-selection-internal + (intern atom-name) + (intern (x-dnd-current-type window)) + timestamp))) + (when value + (condition-case info + (x-dnd-drop-data event frame window value + (x-dnd-current-type window)) + (error + (message "Error: %s" info) + nil)))))) + (x-get-selection-internal + (intern atom-name) + (if action 'XmTRANSFER_SUCCESS 'XmTRANSFER_FAILURE) + timestamp) + (x-dnd-forget-drop frame))))) + + (t (message "Unknown Motif drag-and-drop message: %s" + (logand (aref data 0) #x3f))))))) ;;; + + +;;; Handling drops. + +(defvar x-treat-local-requests-remotely) +(declare-function x-get-local-selection "xfns.c") + +(defun x-dnd-convert-to-offix (targets local-selection) + "Convert local selection data to OffiX data. +TARGETS should be the list of targets currently available in +`XdndSelection'. Return a list of an OffiX type, and data +suitable for passing to `x-change-window-property', or nil if the +data could not be converted. +LOCAL-SELECTION should be the local selection data describing the +selection data to convert." + (let ((x-treat-local-requests-remotely t) + file-name-data string-data) + (cond + ((and (member "FILE_NAME" targets) + (setq file-name-data + (x-get-local-selection local-selection 'FILE_NAME))) + (if (string-match-p "\0" file-name-data) + ;; This means there are multiple file names in + ;; XdndSelection. Convert the file name data to a format + ;; that OffiX understands. + (cons 'DndTypeFiles (concat file-name-data "\0\0")) + (cons 'DndTypeFile (concat file-name-data "\0")))) + ((and (member "STRING" targets) + (setq string-data + (x-get-local-selection local-selection 'STRING))) + (cons 'DndTypeText (encode-coding-string string-data + 'latin-1)))))) + +(defun x-dnd-do-offix-drop (targets x y frame window-id contents) + "Perform an OffiX drop on WINDOW-ID with the given selection contents. +Return non-nil if the drop succeeded, or nil if it did not +happen, which can happen if TARGETS didn't contain anything that +the OffiX protocol can represent. + +X and Y are the root window coordinates of the drop. TARGETS is +the list of targets CONTENTS can be converted to, and CONTENTS is +the local selection data to drop onto the target window. + +FRAME is the frame that will act as a source window for the +drop." + (if-let* ((data (x-dnd-convert-to-offix targets contents)) + (type-id (car (rassq (car data) + x-dnd-offix-id-to-name))) + (source-id (string-to-number + (frame-parameter frame 'window-id))) + (message-data (list type-id ; l[0] = DataType + 0 ; l[1] = event->xbutton.state + source-id ; l[2] = window + (+ x (* 65536 y)) ; l[3] = drop_x + 65536 * drop_y + 1))) ; l[4] = protocol version + (prog1 t + ;; Send a legacy (old KDE) message first. Newer clients will + ;; ignore it, since the protocol version is 1. + (x-change-window-property "DndSelection" + (cdr data) frame + "STRING" 8 nil 0) + (x-send-client-message frame window-id + frame "DndProtocol" + 32 message-data) + ;; Now send a modern _DND_PROTOCOL message. + (x-change-window-property "_DND_SELECTION" + (cdr data) frame + "STRING" 8 nil 0) + (x-send-client-message frame window-id + frame "_DND_PROTOCOL" + 32 message-data)))) + +(defun x-dnd-handle-unsupported-drop (targets x y action window-id frame _time local-selection-data) + "Return non-nil if the drop described by TARGETS and ACTION should not proceed. +X and Y are the root window coordinates of the drop. +FRAME is the frame the drop originated on. +WINDOW-ID is the X window the drop should happen to. +LOCAL-SELECTION-DATA is the local selection data of the drop." + (let ((chosen-action nil)) + (not (and (or (eq action 'XdndActionCopy) + (eq action 'XdndActionMove)) + (not (and x-dnd-use-offix-drop local-selection-data + (or (not (eq x-dnd-use-offix-drop 'files)) + (member "FILE_NAME" targets)) + (when (x-dnd-do-offix-drop targets x + y frame window-id + local-selection-data) + (setq chosen-action 'XdndActionCopy)))) + (let ((delegate-p (or (member "STRING" targets) + (member "UTF8_STRING" targets) + (member "COMPOUND_TEXT" targets) + (member "TEXT" targets)))) + (prog1 delegate-p + ;; A string will avoid the drop emulation done in C + ;; code, but won't be returned from `x-begin-drag'. + (setq chosen-action (unless delegate-p "")))))) + chosen-action)) + +(defvar x-dnd-targets-list) +(defvar x-dnd-native-test-function) + +(defun x-dnd-handle-native-drop (pos action) + "Compute the action for a drop at POS. +Return the appropriate drag-and-drop action for a local drop at POS. +ACTION is the action given to `x-begin-drag'." + (let ((state (funcall x-dnd-test-function + (posn-window pos) + (cdr (assoc (symbol-name action) + x-dnd-xdnd-to-action)) + (apply #'vector x-dnd-targets-list)))) + (when state + (intern (car (rassq (car state) x-dnd-xdnd-to-action)))))) + +(setq x-dnd-native-test-function #'x-dnd-handle-native-drop) + +;;; XDS protocol support. + +(declare-function x-begin-drag "xfns.c") +(declare-function x-delete-window-property "xfns.c") +(defvar selection-converter-alist) + +(defvar x-dnd-xds-current-file nil + "The file name for which a direct save is currently being performed.") + +(defvar x-dnd-xds-source-frame nil + "The frame from which a direct save is currently being performed.") + +(defvar x-dnd-xds-performed nil + "Whether or not the drop target made a request for `XdndDirectSave0'.") + +(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) + (let* ((uri (x-window-property "XdndDirectSave0" + x-dnd-xds-source-frame + "AnyPropertyType" nil t)) + (local-file-uri (if (and (string-match "^file://\\([^/]*\\)" uri) + (not (equal (match-string 1 uri) ""))) + (dnd-get-local-file-uri uri) + uri)) + (local-name (and local-file-uri + (dnd-get-local-file-name local-file-uri)))) + (if (not local-name) + '(STRING . "F") + ;; 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))) + (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'. +Return the contents of the XDS file." + (cons 'application/octet-stream + (ignore-errors + (with-temp-buffer + (set-buffer-multibyte nil) + (setq buffer-file-coding-system 'binary) + (insert-file-contents-literally x-dnd-xds-current-file) + (buffer-substring-no-properties (point-min) + (point-max)))))) + +(defun x-dnd-do-direct-save (file name frame allow-same-frame) + "Perform a direct save operation on FILE, from FRAME. +FILE is the file containing the contents to drop. +NAME is the name that should be given to the file after dropping. +FRAME is the frame from which the drop will originate. +ALLOW-SAME-FRAME means whether or not dropping will be allowed +on FRAME. + +Return the action taken by the drop target, or nil if no action +was taken, or the direct save failed." + (dnd-remove-last-dragged-remote-file) + (let ((file-name file) + (original-file-name file) + (selection-converter-alist + (append '((XdndDirectSave0 . x-dnd-handle-direct-save) + (application/octet-stream . x-dnd-handle-octet-stream)) + selection-converter-alist)) + (x-dnd-xds-current-file nil) + (x-dnd-xds-source-frame frame) + (x-dnd-xds-performed nil) + ;; The XDS protocol is built on top of XDND, and cannot + ;; possibly work with Motif or OffiX programs. + (x-dnd-disable-motif-protocol t) + (x-dnd-use-offix-drop nil) + (x-dnd-use-unsupported-drop nil) + (prop-deleted nil) + encoded-name) + (unwind-protect + (progn + (when (file-remote-p file) + (setq file-name (file-local-copy file)) + (setq dnd-last-dragged-remote-file file-name) + (add-hook 'kill-emacs-hook + #'dnd-remove-last-dragged-remote-file)) + (setq encoded-name + (encode-coding-string name + (or file-name-coding-system + default-file-name-coding-system))) + (setq x-dnd-xds-current-file file-name) + (x-change-window-property "XdndDirectSave0" encoded-name + frame "text/plain" 8 nil) + (gui-set-selection 'XdndSelection (concat "file://" file-name)) + ;; FIXME: this does not work with GTK file managers, since + ;; they always reach for `text/uri-list' first, contrary to + ;; the spec. + (let ((action (x-begin-drag '("XdndDirectSave0" "text/uri-list" + "application/octet-stream") + 'XdndActionDirectSave + frame nil allow-same-frame))) + (if (not x-dnd-xds-performed) + action + (let ((property (x-window-property "XdndDirectSave0" frame + "AnyPropertyType" nil t))) + (setq prop-deleted t) + ;; "System-G" deletes the property upon success. + (and (or (null property) + (and (stringp property) + (not (equal property "")))) + action))))) + (unless prop-deleted + (x-delete-window-property "XdndDirectSave0" frame)) + ;; Delete any remote copy that was made. + (when (not (equal file-name original-file-name)) + (delete-file file-name))))) + +(defun x-dnd-save-direct (need-name name) + "Handle dropping a file that should be saved immediately. +NEED-NAME tells whether or not the file was not yet saved. NAME +is either the name of the file, or the name the drop source wants +us to save under. + +Prompt the user for a file name, then open it." + (if need-name + (let ((file-name (read-file-name "Write file: " + default-directory + nil nil name))) + (when (file-exists-p file-name) + (unless (y-or-n-p (format-message + "File `%s' exists; overwrite? " file-name)) + (setq file-name nil))) + file-name) + ;; TODO: move this to dired.el once a platform-agonistic + ;; interface can be found. + (if (derived-mode-p 'dired-mode) + (revert-buffer) + (find-file name)))) + +(defun x-dnd-save-direct-immediately (need-name name) + "Save and open a dropped file, like `x-dnd-save-direct'. +NEED-NAME tells whether or not the file was not yet saved. NAME +is either the name of the file, or the name the drop source wants +us to save under. + +Unlike `x-dnd-save-direct', do not prompt for the name by which +to save the file. Simply save it in the current directory." + (if need-name + (let ((file-name (expand-file-name name))) + (when (file-exists-p file-name) + (unless (y-or-n-p (format-message + "File `%s' exists; overwrite? " file-name)) + (setq file-name nil))) + file-name) + ;; TODO: move this to dired.el once a platform-agonistic + ;; interface can be found. + (if (derived-mode-p 'dired-mode) + (revert-buffer) + (find-file name)))) + +(defun x-dnd-handle-octet-stream-for-drop (save-to) + "Save the contents of the XDS selection to SAVE-TO. +Return non-nil if successful, nil otherwise." + (ignore-errors + (let ((coding-system-for-write 'raw-text) + (data (x-get-selection-internal 'XdndSelection + 'application/octet-stream))) + (when data + (write-region data nil save-to) + t)))) + +(defun x-dnd-handle-xds-drop (event window source version) + "Handle an XDS (X Direct Save) protocol drop. +EVENT is the drag-n-drop event containing the drop. +WINDOW is the window on top of which the drop is supposed to happen. +SOURCE is the X window that sent the drop. +VERSION is the version of the XDND protocol understood by SOURCE." + (if (not (windowp window)) + ;; We can't perform an XDS drop if there's no window from which + ;; to determine the current directory. + (let* ((start (event-start event)) + (frame (posn-window start))) + (x-send-client-message frame source frame + "XdndFinished" 32 + (list (string-to-number + (frame-parameter frame + 'outer-window-id))))) + (let ((desired-name (x-window-property "XdndDirectSave0" + (window-frame window) + ;; We currently don't handle + ;; any alternative character + ;; encodings. + "text/plain" source)) + (frame (window-frame window)) + (success nil) save-to save-to-remote hostname) + (unwind-protect + (when (stringp desired-name) + (setq desired-name (decode-coding-string + desired-name + (or file-name-coding-system + default-file-name-coding-system))) + (let ((name (funcall x-dnd-direct-save-function + t desired-name))) + (setq save-to name save-to-remote name)) + (when save-to + (if (file-remote-p save-to) + (setq hostname (file-remote-p save-to 'host) + save-to (file-local-name save-to)) + (setq hostname (system-name))) + (with-selected-window window + (let ((uri (format "file://%s%s" hostname save-to))) + (x-change-window-property "XdndDirectSave0" + (encode-coding-string + (url-encode-url uri) 'ascii) + frame "text/plain" 8 nil source) + (let ((result (x-get-selection-internal 'XdndSelection + 'XdndDirectSave0))) + (cond ((equal result "F") + (setq success + (x-dnd-handle-octet-stream-for-drop save-to-remote)) + (unless success + (x-change-window-property "XdndDirectSave0" "" + frame "text/plain" 8 + nil source))) + ((equal result "S") + (setq success t)) + ((equal result "E") + (setq success nil)) + (t (error "Broken implementation of XDS: got %s in reply" + result))) + (when success + (funcall x-dnd-direct-save-function nil save-to-remote))))))) + ;; We assume XDS always comes from a client supporting version 2 + ;; or later, since custom actions aren't present before. + (x-send-client-message frame source frame + "XdndFinished" 32 + (list (string-to-number + (frame-parameter frame + 'outer-window-id)) + (if (>= version 5) + (if success 1 0) + 0) + (if (or (not success) + (< version 5)) + 0 + "XdndDirectSave0"))))))) + +;; Internal wheel movement. + +(defvar x-dnd-wheel-function) + +(defun x-dnd-note-wheel-movement (position button state time) + "Note wheel movement at POSITION. +POSITION is a mouse position list describing the position of the +wheel movement. +BUTTON is the wheel button that was pressed. +STATE is the X modifier state at the time of the wheel movement. +TIME is the X server time at which the wheel moved." + (when (posn-window position) + (with-selected-window (posn-window position) + (let ((count (x-dnd-note-click button time))) + (x-dnd-mwheel-scroll button count state))))) + +(setq x-dnd-wheel-function #'x-dnd-note-wheel-movement) + (provide 'x-dnd) ;;; x-dnd.el ends here |