master 897cc73c88a 1/3: Render default DND file name handlers more precise

[Po Lu]

branch: master
commit 897cc73c88a9da0a2477f1e61501b907eb877a5b
Author: Po Lu <luangruo@yahoo.com>
Commit: Po Lu <luangruo@yahoo.com>

    Render default DND file name handlers more precise
    
    * lisp/dnd.el (dnd-protocol-alist): Redefine file name handlers
    to match solely the local or remote URIs they understand.
    (dnd-handle-multiple-urls): Prevent calling the same handler
    multiple times for a single URI.
    
    * lisp/gnus/mml.el (mml-dnd-protocol-alist): Apply an anologous
    adjustment here.  Delete now redundant redefinition of
    dnd-open-file.
    (mml-dnd-attach-file): Inquire whether to apply the default
    disposition and such only once even if more than one file is
    dropped.
    
    * test/lisp/dnd-tests.el (dnd-tests-receive-multiple-urls)
    (dnd-tests-default-file-name-handlers): New tests.
---
 lisp/dnd.el            | 12 ++++++----
 lisp/gnus/mml.el       | 59 ++++++++++++++++++++++++++--------------------
 test/lisp/dnd-tests.el | 64 +++++++++++++++++++++++++++++++++++++++++++++++++-
 3 files changed, 103 insertions(+), 32 deletions(-)

diff --git a/lisp/dnd.el b/lisp/dnd.el
index c27fdeb7745..ecf9c332e94 100644
--- a/lisp/dnd.el
+++ b/lisp/dnd.el
@@ -42,10 +42,11 @@
 
 ;;;###autoload
 (defcustom dnd-protocol-alist
-  `((,(purecopy "^file:///")  . dnd-open-local-file)   ; XDND format.
-    (,(purecopy "^file://")   . dnd-open-file)         ; URL with host
-    (,(purecopy "^file:")     . dnd-open-local-file)   ; Old KDE, Motif, Sun
-    (,(purecopy "^\\(https?\\|ftp\\|file\\|nfs\\)://") . dnd-open-file))
+  `((,(purecopy "^file:///")    . dnd-open-local-file) ; XDND format.
+    (,(purecopy "^file://[^/]") . dnd-open-file)       ; URL with host
+    (,(purecopy "^file:/[^/]")  . dnd-open-local-file) ; Old KDE, Motif, Sun
+    (,(purecopy "^file:[^/]")   . dnd-open-local-file) ; MS-Windows
+    (,(purecopy "^\\(https?\\|ftp\\|nfs\\)://") . dnd-open-file))
   "The functions to call for different protocols when a drop is made.
 This variable is used by `dnd-handle-multiple-urls'.
 The list contains of (REGEXP . FUNCTION) pairs.
@@ -223,7 +224,8 @@ for it will be modified."
                               (let ((cell (cons handler nil)))
                                 (push cell list)
                                 cell))))
-                (setcdr cell (cons uri (cdr cell))))))))
+                (unless (memq uri cell)
+                  (setcdr cell (cons uri (cdr cell)))))))))
       (setq list (nreverse list))
       ;; While unassessed handlers still exist...
       (while list
diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el
index 6025ca7e72a..24cd5eb83d3 100644
--- a/lisp/gnus/mml.el
+++ b/lisp/gnus/mml.el
@@ -1369,9 +1369,9 @@ If not set, `default-directory' will be used."
 ;;; Attachment functions.
 
 (defcustom mml-dnd-protocol-alist
-  '(("^file:///" . mml-dnd-attach-file)
-    ("^file://"  . dnd-open-file)
-    ("^file:"    . mml-dnd-attach-file))
+  '(("^file:///" . mml-dnd-attach-file) ; GNOME, KDE, and suchlike.
+    ("^file:/[^/]" . mml-dnd-attach-file) ; Motif, other systems.
+    ("^file:[^/]" . mml-dnd-attach-file)) ; MS-Windows.
   "The functions to call when a drop in `mml-mode' is made.
 See `dnd-protocol-alist' for more information.  When nil, behave
 as in other buffers."
@@ -1460,29 +1460,36 @@ will be computed and used."
                 (file-name-nondirectory file)))
       (goto-char at-end))))
 
-(defun mml-dnd-attach-file (uri _action)
-  "Attach a drag and drop file.
-
-Ask for type, description or disposition according to
-`mml-dnd-attach-options'."
-  (let ((file (dnd-get-local-file-name uri t)))
-    (when (and file (file-regular-p file))
-      (let ((mml-dnd-attach-options mml-dnd-attach-options)
-           type description disposition)
-       (setq mml-dnd-attach-options
-             (when (and (eq mml-dnd-attach-options t)
-                        (not
-                         (y-or-n-p
-                          "Use default type, disposition and description? ")))
-               '(type description disposition)))
-       (when (or (memq 'type mml-dnd-attach-options)
-                 (memq 'disposition mml-dnd-attach-options))
-         (setq type (mml-minibuffer-read-type file)))
-       (when (memq 'description mml-dnd-attach-options)
-         (setq description (mml-minibuffer-read-description)))
-       (when (memq 'disposition mml-dnd-attach-options)
-         (setq disposition (mml-minibuffer-read-disposition type nil file)))
-       (mml-attach-file file type description disposition)))))
+(defun mml-dnd-attach-file (uris _action)
+  "Attach a drag and drop URIS, a list of local file URIs.
+
+Query whether to use the types, dispositions and descriptions
+default for each URL, subject to `mml-dnd-attach-options'.
+
+Return the action `private', communicating to the drop source
+that the file has been attached."
+  (let (file (mml-dnd-attach-options mml-dnd-attach-options))
+    (setq mml-dnd-attach-options
+         (when (and (eq mml-dnd-attach-options t)
+                    (not
+                     (y-or-n-p
+                      "Use default type, disposition and description? ")))
+           '(type description disposition)))
+    (dolist (uri uris)
+      (setq file (dnd-get-local-file-name uri t))
+      (when (and file (file-regular-p file))
+        (let (type description disposition)
+         (when (or (memq 'type mml-dnd-attach-options)
+                   (memq 'disposition mml-dnd-attach-options))
+           (setq type (mml-minibuffer-read-type file)))
+         (when (memq 'description mml-dnd-attach-options)
+           (setq description (mml-minibuffer-read-description)))
+         (when (memq 'disposition mml-dnd-attach-options)
+           (setq disposition (mml-minibuffer-read-disposition type nil file)))
+         (mml-attach-file file type description disposition)))))
+  'private)
+
+(put 'mml-dnd-attach-file 'dnd-multiple-handler t)
 
 (defun mml-attach-buffer (buffer &optional type description disposition 
filename)
   "Attach a buffer to the outgoing MIME message.
diff --git a/test/lisp/dnd-tests.el b/test/lisp/dnd-tests.el
index 342b6e49be4..7a7f54ba0bb 100644
--- a/test/lisp/dnd-tests.el
+++ b/test/lisp/dnd-tests.el
@@ -531,7 +531,69 @@ ACTION is ignored.  Return the symbol `private' otherwise."
                                                 dnd-tests-list-4)
                                                'copy)
                      'private))
-      (should (equal (buffer-string) (nth 4 dnd-tests-list-4))))))
+      (should (equal (buffer-string) (nth 4 dnd-tests-list-4))))
+    ;; Check that a handler enumerated twice in the handler list
+    ;; receives URIs assigned to it only once.
+    (let* ((received-p nil)
+           (lambda (lambda (uri _action)
+                     (should (equal uri "scheme1://test"))
+                     (should (null received-p))
+                     (setq received-p 'copy))))
+      (setq dnd-protocol-alist (list (cons "scheme1://" lambda)
+                                     (cons "scheme1://" lambda)))
+      (should (equal (dnd-handle-multiple-urls (selected-window)
+                                               (list "scheme1://test")
+                                               'copy)
+                     'copy)))))
+
+(ert-deftest dnd-tests-default-file-name-handlers ()
+  (let* ((local-files-opened nil)
+         (remote-files-opened nil)
+         (function-1 (lambda (file _uri)
+                       (push file local-files-opened)
+                       'copy))
+         (function-2 (lambda (file _uri)
+                       (push file remote-files-opened)
+                       'copy)))
+    (unwind-protect
+        (progn
+          (advice-add #'dnd-open-local-file :override
+                      function-1)
+          (advice-add #'dnd-open-file :override
+                      function-2)
+          ;; Guarantee that file names are properly categorized as either
+          ;; local or remote by the default dnd-protocol-alist.
+          (dnd-handle-multiple-urls
+           (selected-window)
+           (list
+            ;; These are run-of-the-mill local file URIs.
+            "file:///usr/include/sys/acct.h"
+            "file:///usr/include/sys/acctctl.h"
+            ;; These URIs incorporate a host; they should match
+            ;; function-2 but never function-1.
+            "file://remotehost/usr/src/emacs/configure.ac"
+            "file://remotehost/usr/src/emacs/configure"
+            ;; These URIs are generated by drag-and-drop event
+            ;; handlers from local file names alone; they are not
+            ;; echt URIs in and of themselves, but a product of our
+            ;; drag and drop code.
+            "file:/etc/vfstab"
+            "file:/etc/dfs/sharetab"
+            ;; These URIs are generated under MS-Windows.
+            "file:c:/path/to/file/name"
+            "file:d:/path/to/file/name")
+           'copy)
+          (should (equal (sort local-files-opened #'string<)
+                         '("file:///usr/include/sys/acct.h"
+                           "file:///usr/include/sys/acctctl.h"
+                           "file:/etc/dfs/sharetab"
+                           "file:/etc/vfstab"
+                           "file:c:/path/to/file/name"
+                           "file:d:/path/to/file/name")))
+          (should (equal (sort remote-files-opened #'string<)
+                         '("file://remotehost/usr/src/emacs/configure"
+                           "file://remotehost/usr/src/emacs/configure.ac"))))
+      (advice-remove #'dnd-open-local-file function-2))))
 
 (provide 'dnd-tests)
 ;;; dnd-tests.el ends here