pestctrl/emacs
1
0
Fork 0
forked from Github/emacs
Code Issues Pull requests Projects Releases Packages Wiki Activity

Implement starting X Direct Save (XDS) drops

Browse source 
* 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.
This commit is contained in:
Po Lu 2022-06-29 20:10:25 +08:00
parent 3c0b18facd
commit d07063f69f
8 changed files with 204 additions and 65 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
doc/lispref/frames.texi
View file

@ -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

7
etc/NEWS
View file

@ -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'.

130
lisp/dnd.el
View file

@ -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

110
lisp/x-dnd.el
View file

@ -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

5
src/xfns.c
View file

@ -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;

2
src/xselect.c
View file

@ -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;

7
src/xterm.c
View file

@ -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);

1
src/xterm.h
View file

@ -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 *,