;;;###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.
(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
;;; 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."
(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.
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
projects / emacs.git / commitdiff