[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master ea5f5f81dd 1/2: Support receiving XDS drops correctly
|
From: |
Po Lu |
|
Subject: |
master ea5f5f81dd 1/2: Support receiving XDS drops correctly |
|
Date: |
Fri, 1 Jul 2022 04:19:00 -0400 (EDT) |
branch: master
commit ea5f5f81dd172ce40f10cd5e276d23839c24cbc1
Author: Po Lu <luangruo@yahoo.com>
Commit: Po Lu <luangruo@yahoo.com>
Support receiving XDS drops correctly
* etc/NEWS: Announce new feature. It is not yet documented.
* lisp/x-dnd.el (x-dnd-known-types): Add XdndDirectSave0.
(x-dnd-direct-save-function): New defcustom.
(x-dnd-xdnd-to-action): Add `direct-save'.
(x-dnd-maybe-call-test-function): If XDS is present, use `direct-save'.
(x-dnd-find-type): New function.
(x-dnd-handle-xdnd): Handle XDS position and drop messages.
(x-dnd-handle-direct-save): Don't use local-file-uri if nil.
(x-dnd-save-direct): New function.
(x-dnd-handle-octet-stream-for-drop):
(x-dnd-handle-xds-drop): New functions.
---
etc/NEWS | 5 ++
lisp/x-dnd.el | 266 ++++++++++++++++++++++++++++++++++++++++++++++------------
2 files changed, 219 insertions(+), 52 deletions(-)
diff --git a/etc/NEWS b/etc/NEWS
index d3dd896526..b0a5cd4f1d 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -423,6 +423,11 @@ This inhibits putting empty strings onto the kill ring.
These options allow adjusting point and scrolling a window when
dragging items from another program.
+** The X Direct Save (XDS) protocol is now supported.
+This means dropping an image or file link from programs such as
+Firefox will no longer create a temporary file in a random directory,
+instead asking you where to save the file first.
+
+++
** New user option 'record-all-keys'.
If non-nil, this option will force recording of all input keys,
diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el
index 43905e1bb0..efd774f4e9 100644
--- a/lisp/x-dnd.el
+++ b/lisp/x-dnd.el
@@ -84,7 +84,8 @@ if drop is successful, nil if not."
(defcustom x-dnd-known-types
(mapcar 'purecopy
- '("text/uri-list"
+ '("XdndDirectSave0"
+ "text/uri-list"
"text/x-moz-url"
"_NETSCAPE_URL"
"FILE_NAME"
@@ -120,6 +121,24 @@ like xterm) for text."
(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 local 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 'function
+ :group 'x)
+
;; Internal variables
(defvar x-dnd-current-state nil
@@ -144,7 +163,8 @@ any protocol specific data.")
("XdndActionCopy" . copy)
("XdndActionMove" . move)
("XdndActionLink" . link)
- ("XdndActionAsk" . ask))
+ ("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])
@@ -199,29 +219,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))))
@@ -597,9 +637,21 @@ FORMAT is 32 (not used). MESSAGE is the data part of an
XClientMessageEvent."
(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)))
+ (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
@@ -637,34 +689,39 @@ FORMAT is 32 (not used). MESSAGE is the data part of an
XClientMessageEvent."
(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)
+ (current-action (aref state 5))
+ (current-type (aref state 4))
+ success action value)
(x-display-set-last-user-time 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 success) (< version 5)) 0
- (or (car (rassoc action
- x-dnd-xdnd-to-action))
- 0))))))
- (x-dnd-forget-drop window)))
+ (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))))
@@ -1156,7 +1213,8 @@ ACTION is the action given to `x-begin-drag'."
(not (equal (match-string 1 uri) "")))
(dnd-get-local-file-uri uri)
uri))
- (local-name (dnd-get-local-file-name local-file-uri)))
+ (local-name (and local-file-uri
+ (dnd-get-local-file-name local-file-uri))))
(if (not local-name)
'(STRING . "F")
(condition-case nil
@@ -1239,14 +1297,118 @@ was taken, or the direct save failed."
(and (stringp property)
(not (equal property ""))))
action)))))
- ;; TODO: check for failure and implement selection-based file
- ;; transfer.
(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 (file-remote-p default-directory)
+ ;; TODO: figure out what to do with remote files.
+ nil
+ (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-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)
+ (unwind-protect
+ (when (stringp desired-name)
+ (setq desired-name (decode-coding-string
+ desired-name
+ (or file-name-coding-system
+ default-file-name-coding-system)))
+ (setq save-to (funcall x-dnd-direct-save-function
+ t desired-name))
+ (when save-to
+ (with-selected-window window
+ (let ((uri (format "file://%s%s" (system-name) 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))
+ (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)))))))
+ ;; 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")))))))
+
(provide 'x-dnd)
;;; x-dnd.el ends here