master 25887d634f: Improve compliance with the XDS and XDND protocols

[Po Lu]

branch: master
commit 25887d634f624369559ab072beea0d1e2d6886cd
Author: Po Lu <luangruo@yahoo.com>
Commit: Po Lu <luangruo@yahoo.com>

    Improve compliance with the XDS and XDND protocols
    
    * lisp/select.el (xselect-convert-to-text-uri-list): Return a
    type of `text/uri-list' instead of STRING or C_STRING.
    
    * lisp/x-dnd.el (x-dnd-xds-performed): New defvar.
    (x-dnd-handle-direct-save): Set it to t and handle URIs with
    hostnames correctly. Also return errors correctly.
    (x-dnd-handle-octet-stream): New function.
    (x-dnd-do-direct-save): Handle application/octet-stream, check
    results.
---
 lisp/select.el | 22 ++++++++++++----------
 lisp/x-dnd.el  | 58 ++++++++++++++++++++++++++++++++++++++++++++++------------
 2 files changed, 58 insertions(+), 22 deletions(-)

diff --git a/lisp/select.el b/lisp/select.el
index 127a6a5c61..8ffe16e7b3 100644
--- a/lisp/select.el
+++ b/lisp/select.el
@@ -721,16 +721,18 @@ This function returns the string \"emacs\"."
   (user-real-login-name))
 
 (defun xselect-convert-to-text-uri-list (_selection _type value)
-  (if (stringp value)
-      (xselect--encode-string 'TEXT
-                              (concat (url-encode-url value) "\n"))
-    (when (vectorp value)
-      (with-temp-buffer
-        (cl-loop for tem across value
-                 do (progn
-                      (insert (url-encode-url tem))
-                      (insert "\n")))
-        (xselect--encode-string 'TEXT (buffer-string))))))
+  (let ((string
+         (if (stringp value)
+             (xselect--encode-string 'TEXT
+                                     (concat (url-encode-url value) "\n"))
+           (when (vectorp value)
+             (with-temp-buffer
+               (cl-loop for tem across value
+                        do (progn
+                             (insert (url-encode-url tem))
+                             (insert "\n")))
+               (xselect--encode-string 'TEXT (buffer-string)))))))
+    (cons 'text/uri-list (cdr string))))
 
 (defun xselect-convert-to-xm-file (selection _type value)
   (when (and (stringp value)
diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el
index d92009f85c..762d42175e 100644
--- a/lisp/x-dnd.el
+++ b/lisp/x-dnd.el
@@ -1140,23 +1140,43 @@ ACTION is the action given to `x-begin-drag'."
 (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'.")
+
 (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-name (dnd-get-local-file-name uri nil)))
+         (local-file-uri (if (and (string-match "^file://\\([^/]*\\)" uri)
+                                  (not (equal (match-string 1 uri) "")))
+                             (dnd-get-local-file-uri uri)
+                           uri))
+         (local-name (dnd-get-local-file-name local-file-uri)))
     (if (not local-name)
         '(STRING . "F")
       (condition-case nil
           (progn
-            (rename-file x-dnd-xds-current-file
-                         local-name t)
+            (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 . "F"))))))
+        (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.
@@ -1166,16 +1186,19 @@ 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."
+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
-         (cons (cons 'XdndDirectSave0
-                     #'x-dnd-handle-direct-save)
-               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)
+        (prop-deleted nil)
         encoded-name)
     (unwind-protect
         (progn
@@ -1195,12 +1218,23 @@ Return the action taken by the drop target, or nil."
           ;; 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))
+          (let ((action (x-begin-drag '("XdndDirectSave0" "text/uri-list")
+                                      '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)))))
       ;; TODO: check for failure and implement selection-based file
       ;; transfer.
-      (x-delete-window-property "XdndDirectSave0" frame)
+      (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)))))