[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master d07063f69f 1/2: Implement starting X Direct Save (XDS) drops
|
From: |
Po Lu |
|
Subject: |
master d07063f69f 1/2: Implement starting X Direct Save (XDS) drops |
|
Date: |
Wed, 29 Jun 2022 08:14:51 -0400 (EDT) |
branch: master
commit d07063f69fab25da49c69e7790223511d61e9098
Author: Po Lu <luangruo@yahoo.com>
Commit: Po Lu <luangruo@yahoo.com>
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 16f7ad312a..860258a964 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 add7784ade..ce32542028 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 9d72a4b595..29f4ca98ec 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 5c6d25ba68..5820cae29b 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 36920035d7..9dcf73da1c 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 a1f590632f..7993899b2c 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 33c8d4199e..76da1064eb 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 ff81babc33..f7b93529cb 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 *,