From: Po Lu Date: Sat, 28 Oct 2023 06:42:48 +0000 (+0000) Subject: Render default DND file name handlers more precise X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=897cc73c88a9da0a2477f1e61501b907eb877a5b;p=emacs.git 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. --- 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