From d07063f69fab25da49c69e7790223511d61e9098 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Wed, 29 Jun 2022 20:10:25 +0800 Subject: [PATCH] Implement starting X Direct Save (XDS) drops * doc/lispref/frames.texi (Drag and Drop): Document new function `dnd-direct-save'. * etc/NEWS: Likewise. * lisp/dnd.el (dnd-direct-save-remote-files): New defcustom. (dnd-begin-file-drag): Implement defucstom. (dnd-begin-drag-files): Add kill-emacs-hook after saving remote file. (dnd-direct-save): New function. * lisp/x-dnd.el (x-dnd-known-types): Fix coding style. (x-dnd-handle-drag-n-drop-event): Handle local value with self-originating DND events. (x-dnd-xds-current-file, x-dnd-xds-source-frame): New defvars. (x-dnd-handle-direct-save, x-dnd-do-direct-save): New functions. * src/xfns.c (Fx_begin_drag): Allow any atom to be used as a DND action. * src/xselect.c (symbol_to_x_atom): Make public. * src/xterm.c (x_dnd_note_self_drop): Include selection local value. (x_ignore_errors_for_next_request): Don't assume x_error_message is set. * src/xterm.h: Update prototypes. --- doc/lispref/frames.texi | 7 +++ etc/NEWS | 7 ++- lisp/dnd.el | 130 +++++++++++++++++++++++++++------------- lisp/x-dnd.el | 110 ++++++++++++++++++++++++++++------ src/xfns.c | 5 ++ src/xselect.c | 2 +- src/xterm.c | 7 ++- src/xterm.h | 1 + 8 files changed, 204 insertions(+), 65 deletions(-) diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi index 16f7ad312a4..860258a9648 100644 --- a/doc/lispref/frames.texi +++ b/doc/lispref/frames.texi @@ -4186,6 +4186,13 @@ This function is like @code{dnd-begin-file-drag}, except that dropping multiple files, then the first file will be used instead. @end defun +@defun dnd-direct-save file name &optional frame allow-same-frame +This function is similar to @code{dnd-begin-file-drag} (with the +default action of copy), but instead of specifying the action you +specify the name of the copy created by the target program in +@code{name}. +@end defun + @cindex initiating drag-and-drop, low-level The high-level interfaces described above are implemented on top of a lower-level primitive. If you need to drag content other than files diff --git a/etc/NEWS b/etc/NEWS index add7784ade3..ce325420289 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2343,9 +2343,10 @@ list in reported motion events if there is no frame underneath the mouse pointer. +++ -** New functions 'x-begin-drag', 'dnd-begin-text-drag' and 'dnd-begin-file-drag'. -These functions allow dragging contents (such as files and text) from -Emacs to other programs. +** New functions for dragging items from Emacs to other programs. +The new functions 'x-begin-drag', 'dnd-begin-file-drag', +'dnd-begin-drag-files', and 'dnd-direct-save' allow dragging contents +(such as files and text) from Emacs to other programs. --- ** New function 'ietf-drums-parse-date-string'. diff --git a/lisp/dnd.el b/lisp/dnd.el index 9d72a4b5958..29f4ca98ec8 100644 --- a/lisp/dnd.el +++ b/lisp/dnd.el @@ -106,6 +106,18 @@ program." :version "29.1" :group 'dnd) +(defcustom dnd-direct-save-remote-files 'x + "Whether or not to perform a direct save of remote files. +This is compatible with less programs, but means dropped files +will be saved with their actual file names, and not a temporary +file name provided by TRAMP. + +This defaults to `x', which means only to drop that way on X +Windows." + :type '(choice (const :tag "Only use direct save on X Windows" x) + (const :tag "Use direct save everywhere" t) + (const :tag "Don't use direct save"))) + ;; Functions (defun dnd-handle-movement (posn) @@ -409,48 +421,58 @@ currently being held down. It should only be called upon a (dnd-remove-last-dragged-remote-file) (unless action (setq action 'copy)) - (let ((original-file file)) - (when (file-remote-p file) - (if (eq action 'link) - (error "Cannot create symbolic link to remote file") - (setq file (file-local-copy file)) - (setq dnd-last-dragged-remote-file file) - (add-hook 'kill-emacs-hook - #'dnd-remove-last-dragged-remote-file))) - (gui-set-selection 'XdndSelection - (propertize (expand-file-name file) 'text/uri-list - (concat "file://" - (expand-file-name file)))) - (let ((return-value - (x-begin-drag '(;; Xdnd types used by GTK, Qt, and most other - ;; modern programs that expect filenames to - ;; be supplied as URIs. - "text/uri-list" "text/x-xdnd-username" - ;; Traditional X selection targets used by - ;; programs supporting the Motif - ;; drag-and-drop protocols. Also used by NS - ;; and Haiku. - "FILE_NAME" "FILE" "HOST_NAME" - ;; ToolTalk filename. Mostly used by CDE - ;; programs. - "_DT_NETFILE") - (cl-ecase action - ('copy 'XdndActionCopy) - ('move 'XdndActionMove) - ('link 'XdndActionLink)) - frame nil allow-same-frame))) - (cond - ((eq return-value 'XdndActionCopy) 'copy) - ((eq return-value 'XdndActionMove) - (prog1 'move - ;; If original-file is a remote file, delete it from the - ;; remote as well. - (when (file-remote-p original-file) - (ignore-errors - (delete-file original-file))))) - ((eq return-value 'XdndActionLink) 'link) - ((not return-value) nil) - (t 'private))))) + (if (and (or (and (eq dnd-direct-save-remote-files 'x) + (eq (framep (or frame + (selected-frame))) + 'x)) + (and dnd-direct-save-remote-files + (not (eq dnd-direct-save-remote-files 'x)))) + (eq action 'copy) + (file-remote-p file)) + (dnd-direct-save file (file-name-nondirectory file) + frame allow-same-frame) + (let ((original-file file)) + (when (file-remote-p file) + (if (eq action 'link) + (error "Cannot create symbolic link to remote file") + (setq file (file-local-copy file)) + (setq dnd-last-dragged-remote-file file) + (add-hook 'kill-emacs-hook + #'dnd-remove-last-dragged-remote-file))) + (gui-set-selection 'XdndSelection + (propertize (expand-file-name file) 'text/uri-list + (concat "file://" + (expand-file-name file)))) + (let ((return-value + (x-begin-drag '(;; Xdnd types used by GTK, Qt, and most other + ;; modern programs that expect filenames to + ;; be supplied as URIs. + "text/uri-list" "text/x-xdnd-username" + ;; Traditional X selection targets used by + ;; programs supporting the Motif + ;; drag-and-drop protocols. Also used by NS + ;; and Haiku. + "FILE_NAME" "FILE" "HOST_NAME" + ;; ToolTalk filename. Mostly used by CDE + ;; programs. + "_DT_NETFILE") + (cl-ecase action + ('copy 'XdndActionCopy) + ('move 'XdndActionMove) + ('link 'XdndActionLink)) + frame nil allow-same-frame))) + (cond + ((eq return-value 'XdndActionCopy) 'copy) + ((eq return-value 'XdndActionMove) + (prog1 'move + ;; If original-file is a remote file, delete it from the + ;; remote as well. + (when (file-remote-p original-file) + (ignore-errors + (delete-file original-file))))) + ((eq return-value 'XdndActionLink) 'link) + ((not return-value) nil) + (t 'private)))))) (defun dnd-begin-drag-files (files &optional frame action allow-same-frame) "Begin dragging FILES from FRAME. @@ -477,6 +499,9 @@ FILES will be dragged." (error (message "Failed to download file: %s" error) (setcar tem nil)))) (setq tem (cdr tem))) + (when dnd-last-dragged-remote-file + (add-hook 'kill-emacs-hook + #'dnd-remove-last-dragged-remote-file)) ;; Remove any files that failed to download from a remote host. (setq new-files (delq nil new-files)) (unless new-files @@ -520,6 +545,27 @@ FILES will be dragged." ((not return-value) nil) (t 'private))))) +(declare-function x-dnd-do-direct-save "x-dnd.el") + +(defun dnd-direct-save (file name &optional frame allow-same-frame) + "Drag FILE from FRAME, but do not treat it as an actual file. +Instead, ask the target window to insert the file with NAME. +File managers will create a file in the displayed directory with +the contents of FILE and the name NAME, while text editors will +insert the contents of FILE in a new document named +NAME. + +ALLOW-SAME-FRAME means the same as in `dnd-begin-file-drag'. +Return `copy' if the drop was successful, else nil." + (setq file (expand-file-name file)) + (cond ((eq window-system 'x) + (when (x-dnd-do-direct-save file name frame + allow-same-frame) + 'copy)) + ;; Avoid infinite recursion. + (t (let ((dnd-direct-save-remote-files nil)) + (dnd-begin-file-drag file frame nil allow-same-frame))))) + (provide 'dnd) ;;; dnd.el ends here diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el index 5c6d25ba686..5820cae29bc 100644 --- a/lisp/x-dnd.el +++ b/lisp/x-dnd.el @@ -84,20 +84,20 @@ 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" - "DndTypeFile" - "DndTypeText")) + '("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" @@ -380,7 +380,8 @@ Currently XDND, Motif and old KDE 1.x protocols are recognized." (progn (let ((action (cdr (assoc (symbol-name (cadr client-message)) x-dnd-xdnd-to-action))) - (targets (cddr client-message))) + (targets (cddr client-message)) + (local-value (nth 2 client-message))) (x-dnd-save-state window nil nil (apply #'vector targets)) (x-dnd-maybe-call-test-function window action) @@ -388,8 +389,8 @@ Currently XDND, Motif and old KDE 1.x protocols are recognized." (x-dnd-drop-data event (if (framep window) window (window-frame window)) window - (x-get-selection-internal - 'XdndSelection + (x-get-local-selection + local-value (intern (x-dnd-current-type window))) (x-dnd-current-type window)) (x-dnd-forget-drop window)))) @@ -1124,6 +1125,81 @@ ACTION is the action given to `x-begin-drag'." (setq x-dnd-native-test-function #'x-dnd-handle-native-drop) +;;; XDS protocol support. + +(declare-function x-begin-drag "xfns.c") + +(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.") + +(defun x-dnd-handle-direct-save (_selection _type _value) + "Handle a selection request for `XdndDirectSave'." + (let* ((uri (x-window-property "XdndDirectSave0" + x-dnd-xds-source-frame + "AnyPropertyType" nil t)) + (local-name (dnd-get-local-file-name uri nil))) + (if (not local-name) + '(STRING . "F") + (condition-case nil + (progn + (rename-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 . "F")))))) + +(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." + (dnd-remove-last-dragged-remote-file) + (let ((file-name file) + (original-file-name file) + (selection-converter-alist + (cons (cons 'XdndDirectSave0 + #'x-dnd-handle-direct-save) + selection-converter-alist)) + (x-dnd-xds-current-file nil) + (x-dnd-xds-source-frame frame) + 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. + (x-begin-drag '("XdndDirectSave0" "text/uri-list") + 'XdndActionDirectSave + frame nil allow-same-frame)) + ;; TODO: check for failure and implement selection-based file + ;; transfer. + (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))))) + (provide 'x-dnd) ;;; x-dnd.el ends here diff --git a/src/xfns.c b/src/xfns.c index 36920035d7f..9dcf73da1ca 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -6936,6 +6936,11 @@ that mouse buttons are being held down, such as immediately after a xaction = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionPrivate; else if (EQ (action, QXdndActionAsk)) xaction = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionAsk; + else if (SYMBOLP (action)) + /* This is to accommodate non-standard DND protocols such as XDS + that are explictly implemented by Emacs, and is not documented + for that reason. */ + xaction = symbol_to_x_atom (FRAME_DISPLAY_INFO (f), action); else if (CONSP (action)) { xaction = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionAsk; diff --git a/src/xselect.c b/src/xselect.c index a1f590632f8..7993899b2c9 100644 --- a/src/xselect.c +++ b/src/xselect.c @@ -121,7 +121,7 @@ selection_quantum (Display *display) /* This converts a Lisp symbol to a server Atom, avoiding a server roundtrip whenever possible. */ -static Atom +Atom symbol_to_x_atom (struct x_display_info *dpyinfo, Lisp_Object sym) { Atom val; diff --git a/src/xterm.c b/src/xterm.c index 33c8d4199e5..76da1064eb9 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -4699,6 +4699,9 @@ x_dnd_note_self_drop (struct x_display_info *dpyinfo, Window target, XFree (atom_names[i - 1]); } + lval = Fcons (assq_no_quit (QXdndSelection, + FRAME_TERMINAL (f)->Vselection_alist), + lval); lval = Fcons (intern (name), lval); lval = Fcons (QXdndSelection, lval); ie.arg = lval; @@ -23030,8 +23033,8 @@ x_ignore_errors_for_next_request (struct x_display_info *dpyinfo) { /* There is no point in making this extra sync if all requests are known to have been fully processed. */ - if ((LastKnownRequestProcessed (x_error_message->dpy) - != NextRequest (x_error_message->dpy) - 1)) + if ((LastKnownRequestProcessed (dpyinfo->display) + != NextRequest (dpyinfo->display) - 1)) XSync (dpyinfo->display, False); x_clean_failable_requests (dpyinfo); diff --git a/src/xterm.h b/src/xterm.h index ff81babc337..f7b93529cbd 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -1576,6 +1576,7 @@ extern void x_handle_selection_notify (const XSelectionEvent *); extern void x_handle_selection_event (struct selection_input_event *); extern void x_clear_frame_selections (struct frame *); extern Lisp_Object x_atom_to_symbol (struct x_display_info *, Atom); +extern Atom symbol_to_x_atom (struct x_display_info *, Lisp_Object); extern bool x_handle_dnd_message (struct frame *, const XClientMessageEvent *, -- 2.39.5