From: Po Lu Date: Thu, 26 Oct 2023 11:37:58 +0000 (+0000) Subject: Enable DND handlers to receive more than one URI at a time X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=11f44ec6dda8660ad5270ee7c76d8b48062dc327;p=emacs.git Enable DND handlers to receive more than one URI at a time * doc/lispref/frames.texi (Drag and Drop): Illustrate the effect of the dnd-multiple-handler property and how convergent handlers are reconciled. * etc/NEWS (Lisp Changes in Emacs 30.1): Announce this change. * lisp/dnd.el (dnd-protocol-alist): Bring doc string up to date. (dnd-handle-one-url): Obsolete this function. (dnd-handle-multiple-urls): New function. * lisp/pgtk-dnd.el (pgtk-dnd-handle-uri-list) (pgtk-dnd-handle-file-name): * lisp/term/android-win.el (android-handle-dnd-event): * lisp/term/haiku-win.el (haiku-drag-and-drop): * lisp/term/ns-win.el (ns-drag-n-drop): * lisp/term/w32-win.el (w32-handle-dropped-file): * lisp/x-dnd.el (x-dnd-handle-uri-list, x-dnd-handle-file-name): Reimplement in terms of `dnd-handle-multiple-uris'. * lisp/term/pgtk-win.el (pgtk-drag-n-drop) (pgtk-drag-n-drop-other-frame, pgtk-drag-n-drop-as-text): Efface detritus that remained after the removal of the old PGTK drag and drop implementation. * test/lisp/dnd-tests.el (ert-x, dnd-tests-list-1) (dnd-tests-list-2, dnd-tests-list-3, dnd-tests-list-4) (dnd-tests-local-file-function, dnd-tests-remote-file-function) (dnd-tests-http-scheme-function, dnd-tests-browse-url-handler) (dnd-tests-receive-multiple-urls): New tests. --- diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi index ef5ed146015..5013cd28420 100644 --- a/doc/lispref/frames.texi +++ b/doc/lispref/frames.texi @@ -4724,9 +4724,9 @@ seldom consistent medley of data types. @cindex drag and drop Data transferred by drag and drop is generally either plain text or -a URL designating a file or another resource. When text is dropped, -it is inserted at the location of the drop, with recourse to saving it -into the kill ring if that is not possible. +a list of URLs designating files or other resources. When text is +dropped, it is inserted at the location of the drop, with recourse to +saving it into the kill ring if that is not possible. URLs dropped are supplied to pertinent @dfn{DND handler functions} in the variable @code{dnd-protocol-alist}, or alternatively ``URL @@ -4740,9 +4740,14 @@ This variable is an alist between regexps against which URLs are matched and DND handler functions called on the dropping of matching URLs. -Each handler function is called with the URL that matched it and one -of the symbols @code{copy}, @code{move}, @code{link}, @code{private} -or @code{ask} identifying the action to be taken. +@cindex dnd-multiple-handler, a symbol property +If a handler function is a symbol whose @code{dnd-multiple-handler} +property (@pxref{Symbol Properties}) is set, then upon a drop it is +given a list of every URL that matches its regexp; absent this +property, it is called once for each of those URLs. Following this +first argument is one of the symbols @code{copy}, @code{move}, +@code{link}, @code{private} or @code{ask} identifying the action to be +taken. If @var{action} is @code{private}, the program that initiated the drop does not insist on any particular behavior on the part of its @@ -4750,19 +4755,29 @@ recipient; a reasonable action to take in that case is to open the URL or copy its contents into the current buffer. The other values of @var{action} imply much the same as in the @var{action} argument to @code{dnd-begin-file-drag}. + +Once its work completes, a handler function must return a symbol +designating the action it took: either the action it was provided, or +the symbol @code{private}, which communicates to the source of the +drop that the action it prescribed has not been executed. + +When multiple handlers match an overlapping subset of items within a +drop, the handler matched against by the greatest number of items is +called to open that subset. The items it is supplied are subsequently +withheld from other handlers, even those they also match. @end defvar @cindex drag and drop, X @cindex drag and drop, other formats - Emacs does not take measures to accept data besides text and URLs by -default, for the window system interfaces which enable this are too -far removed from each other to abstract over consistently. Nor are -DND handlers accorded the capacity to influence the action they are -meant to take, as particular drag-and-drop protocols deny recipients -such control. The X11 drag-and-drop implementation rests on several -underlying protocols that make use of selection transfer and share -much in common, to which low level access is provided through the -following functions and variables: + Emacs does not take measures to accept data besides text and URLs, +for the window system interfaces which enable this are too far removed +from each other to abstract over consistently. Nor are DND handlers +accorded influence over the actions they are meant to take, as +particular drag-and-drop protocols deny recipients such control. The +X11 drag-and-drop implementation rests on several underlying protocols +that make use of selection transfer and share much in common, to which +low level access is provided through the following functions and +variables: @defvar x-dnd-test-function This function is called to ascertain whether Emacs should accept a diff --git a/etc/NEWS b/etc/NEWS index 99bf52eab77..3ad886bdc2b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1122,6 +1122,16 @@ values. * Lisp Changes in Emacs 30.1 ++++ +** Drag-and-drop functions can now be called once for compound drops. +It is now possible for drag-and-drop handler functions to respond to +drops incorporating more than one URL. Functions capable of this must +set their 'dnd-multiple-handler' symbol properties to a non-nil value. +See the Info node "(elisp)Drag and Drop". + +Incident to this change, the function 'dnd-handle-one-url' has been +made obsolete, for it cannot take these new handlers into account. + ** New function 're-disassemble' to see the innards of a regexp. If you compiled with '--enable-checking', you can use this to help debug either your regexp performance problems or the regexp engine. diff --git a/lisp/dnd.el b/lisp/dnd.el index 14581e3d414..c27fdeb7745 100644 --- a/lisp/dnd.el +++ b/lisp/dnd.el @@ -46,13 +46,14 @@ (,(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)) - "The functions to call for different protocols when a drop is made. -This variable is used by `dnd-handle-one-url' and `dnd-handle-file-name'. +This variable is used by `dnd-handle-multiple-urls'. The list contains of (REGEXP . FUNCTION) pairs. The functions shall take two arguments, URL, which is the URL dropped and ACTION which is the action to be performed for the drop (move, copy, link, private or ask). +If a function's `dnd-multiple-handler' property is set, it is provided +a list of each URI dropped instead. If no match is found here, and the value of `browse-url-browser-function' is a pair of (REGEXP . FUNCTION), those regexps are tried for a match. If no match is found, the URL is inserted as text by calling `dnd-insert-text'. @@ -159,7 +160,10 @@ If no match is found here, `browse-url-handlers' and `browse-url-default-handlers' are searched for a match. If no match is found, just call `dnd-insert-text'. WINDOW is where the drop happened, ACTION is the action for the drop, URL -is what has been dropped. Returns ACTION." +is what has been dropped. Returns ACTION. + +This function has been obsolete since Emacs 30.1; it has been +supplanted by `dnd-handle-multiple-urls'." (let (ret) (or (catch 'done @@ -180,6 +184,90 @@ is what has been dropped. Returns ACTION." (setq ret 'private))) ret)) +(make-obsolete 'dnd-handle-one-url 'dnd-handle-multiple-urls "30.1") + +(defun dnd-handle-multiple-urls (window urls action) + "Select a handler for, then open, each element of URLS. +The argument ACTION is the action which must be taken, much as +that to `dnd-begin-file-drag'. + +Assign and give each URL to one of the \"DND handler\" functions +listed in the variable `dnd-protocol-alist'. When multiple +handlers matching the same subset of URLs exist, give precedence +to the handler assigned the greatest number of URLs. + +If a handler is a symbol with the property +`dnd-multiple-handler', call it with ACTION and a list of every +URL it is assigned. Otherwise, call it once for each URL +assigned with ACTION and the URL in question. + +Subsequently open URLs that don't match any handlers opened with +any handler selected by `browse-url-select-handler', and failing +even that, insert them with `dnd-insert-text'. + +Return a symbol designating the actions taken by each DND handler +called. If all DND handlers called return the same symbol, +return that symbol; otherwise, or if no DND handlers are called, +return `private'. + +Do not rely on the contents of URLS after calling this function, +for it will be modified." + (let ((list nil) (return-value nil)) + (with-selected-window window + (dolist (handler dnd-protocol-alist) + (let ((pattern (car handler)) + (handler (cdr handler))) + (dolist (uri urls) + (when (string-match pattern uri) + (let ((cell (or (cdr (assq handler list)) + (let ((cell (cons handler nil))) + (push cell list) + cell)))) + (setcdr cell (cons uri (cdr cell)))))))) + (setq list (nreverse list)) + ;; While unassessed handlers still exist... + (while list + ;; Sort list by the number of URLs assigned to each handler. + (setq list (sort list (lambda (first second) + (> (length (cdr first)) + (length (cdr second)))))) + ;; Call the handler in its car before removing each URL from + ;; URLs. + (let ((handler (caar list)) + (entry-urls (cdar list))) + (setq list (cdr list)) + (when entry-urls + (if (and (symbolp handler) + (get handler 'dnd-multiple-handler)) + (progn + (let ((value (funcall handler entry-urls action))) + (if (or (not return-value) + (eq return-value value)) + (setq return-value value) + (setq return-value 'private))) + (dolist (url entry-urls) + (setq urls (delq url urls)) + ;; And each handler-URL list after this. + (dolist (item list) + (setcdr item (delq url (cdr item)))))) + (dolist (url entry-urls) + (let ((value (funcall handler url action))) + (if (or (not return-value) (eq return-value value)) + (setq return-value value) + (setq return-value 'private))) + (setq urls (delq url urls)) + ;; And each handler-URL list after this. + (dolist (item list) + (setcdr item (delq url (cdr item))))))))) + ;; URLS should now incorporate only those which haven't been + ;; assigned their own handlers. + (dolist (leftover urls) + (setq return-value 'private) + (if-let ((handler (browse-url-select-handler leftover + 'internal))) + (funcall handler leftover action) + (dnd-insert-text window action leftover))) + (or return-value 'private)))) (defun dnd-get-local-file-uri (uri) "Return an uri converted to file:/// syntax if uri is a local file. diff --git a/lisp/pgtk-dnd.el b/lisp/pgtk-dnd.el index f2998fd1e67..2ce1571aefc 100644 --- a/lisp/pgtk-dnd.el +++ b/lisp/pgtk-dnd.el @@ -238,10 +238,9 @@ WINDOW is the window where the drop happened. STRING is the uri-list as a string. The URIs are separated by \\r\\n." (let ((uri-list (split-string string "[\0\r\n]" t)) retval) - (dolist (bf uri-list) - ;; If one URL is handled, treat as if the whole drop succeeded. - (let ((did-action (dnd-handle-one-url window action bf))) - (when did-action (setq retval did-action)))) + (let ((did-action (dnd-handle-multiple-urls window uri-list + action))) + (when did-action (setq retval did-action))) retval)) (defun pgtk-dnd-handle-file-name (window action string) @@ -252,17 +251,21 @@ STRING is the file names as a string, separated by nulls." (coding (or file-name-coding-system default-file-name-coding-system)) retval) - (dolist (bf uri-list) - ;; If one URL is handled, treat as if the whole drop succeeded. - (if coding (setq bf (encode-coding-string bf coding))) - (let* ((file-uri (concat "file://" - (mapconcat 'url-hexify-string - (split-string bf "/") "/"))) - (did-action (dnd-handle-one-url window action file-uri))) - (when did-action (setq retval did-action)))) + (let ((did-action + (dnd-handle-multiple-urls + window action (mapcar + (lambda (item) + (when coding + (setq item (encode-coding-string item + coding))) + (concat "file://" + (mapconcat 'url-hexify-string + (split-string item "/") + "/"))) + uri-list)))) + (when did-action (setq retval did-action))) retval)) - (defun pgtk-dnd-choose-type (types &optional known-types) "Choose which type we want to receive for the drop. TYPES are the types the source of the drop offers, a vector of type names diff --git a/lisp/term/android-win.el b/lisp/term/android-win.el index f3f5c227df0..b73251456fa 100644 --- a/lisp/term/android-win.el +++ b/lisp/term/android-win.el @@ -272,6 +272,7 @@ content:// URIs into the special file names which represent them." ((eq (car message) 'uri) (let ((uri-list (split-string (cdr message) "[\0\r\n]" t)) + (new-uri-list nil) (dnd-unescape-file-uris t)) (dolist (uri uri-list) (ignore-errors @@ -286,7 +287,9 @@ content:// URIs into the special file names which represent them." ;; subject to URI decoding, for it must be ;; transformed back into a content URI. dnd-unescape-file-uris nil)))) - (dnd-handle-one-url (posn-window posn) 'copy uri))))))) + (push uri new-uri-list)) + (dnd-handle-multiple-urls (posn-window posn) 'copy + new-uri-list)))))) (define-key special-event-map [drag-n-drop] 'android-handle-dnd-event) diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el index 50c9cb5b9d4..f53cf7939b9 100644 --- a/lisp/term/haiku-win.el +++ b/lisp/term/haiku-win.el @@ -369,14 +369,15 @@ or a pair of markers) and turns it into a file system reference." ((posn-area (event-start event))) ((assoc "refs" string) (with-selected-window window - (dolist (filename (cddr (assoc "refs" string))) - (dnd-handle-one-url window action - (concat "file:" filename))))) + (dnd-handle-multiple-urls + window (mapcar + (lambda (name) (concat "file:" name)) + (cddr (assoc "refs" string))) + action))) ((assoc "text/uri-list" string) (dolist (text (cddr (assoc "text/uri-list" string))) (let ((uri-list (split-string text "[\0\r\n]" t))) - (dolist (bf uri-list) - (dnd-handle-one-url window action bf))))) + (dnd-handle-multiple-urls window uri-list action)))) ((assoc "text/plain" string) (with-selected-window window (dolist (text (cddr (assoc "text/plain" string))) diff --git a/lisp/term/ns-win.el b/lisp/term/ns-win.el index 7525b9321ca..e40a0ce3e96 100644 --- a/lisp/term/ns-win.el +++ b/lisp/term/ns-win.el @@ -520,11 +520,12 @@ string dropped into the current buffer." (goto-char (posn-point (event-start event))) (cond ((or (memq 'ns-drag-operation-generic operations) (memq 'ns-drag-operation-copy operations)) - ;; Perform the default/copy action. - (dolist (data objects) - (dnd-handle-one-url window 'private (if (eq type 'file) - (concat "file:" data) - data)))) + (let ((urls (if (eq type 'file) (mapcar + (lambda (file) + (concat "file:" file)) + objects) + objects))) + (dnd-handle-multiple-urls window urls 'private))) (t ;; Insert the text as is. (dnd-insert-text window 'private string)))))) diff --git a/lisp/term/pgtk-win.el b/lisp/term/pgtk-win.el index f2552d3b057..ef854a28278 100644 --- a/lisp/term/pgtk-win.el +++ b/lisp/term/pgtk-win.el @@ -48,45 +48,6 @@ (declare-function pgtk-use-im-context "pgtkim.c") -(defun pgtk-drag-n-drop (event &optional new-frame force-text) - "Edit the files listed in the drag-n-drop EVENT. -Switch to a buffer editing the last file dropped." - (interactive "e") - (let* ((window (posn-window (event-start event))) - (arg (car (cdr (cdr event)))) - (type (car arg)) - (data (car (cdr arg))) - (url-or-string (cond ((eq type 'file) - (concat "file:" data)) - (t data)))) - (set-frame-selected-window nil window) - (when new-frame - (select-frame (make-frame))) - (raise-frame) - (setq window (selected-window)) - (if force-text - (dnd-insert-text window 'private data) - (dnd-handle-one-url window 'private url-or-string)))) - -(defun pgtk-drag-n-drop-other-frame (event) - "Edit the files listed in the drag-n-drop EVENT, in other frames. -May create new frames, or reuse existing ones. The frame editing -the last file dropped is selected." - (interactive "e") - (pgtk-drag-n-drop event t)) - -(defun pgtk-drag-n-drop-as-text (event) - "Drop the data in EVENT as text." - (interactive "e") - (pgtk-drag-n-drop event nil t)) - -(defun pgtk-drag-n-drop-as-text-other-frame (event) - "Drop the data in EVENT as text in a new frame." - (interactive "e") - (pgtk-drag-n-drop event t t)) - -(global-set-key [drag-n-drop] 'pgtk-drag-n-drop) - (defun pgtk-suspend-error () "Don't allow suspending if any of the frames are PGTK frames." (if (memq 'pgtk (mapcar 'window-system (frame-list))) @@ -392,7 +353,6 @@ Users should not call this function; see `device-class' instead." (defvaralias 'x-gtk-use-system-tooltips 'use-system-tooltips) - (define-key special-event-map [drag-n-drop] #'pgtk-dnd-handle-drag-n-drop-event) (add-hook 'after-make-frame-functions #'pgtk-dnd-init-frame) diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index c9e25f4f83d..4f1fd475392 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el @@ -117,12 +117,14 @@ (split-string (encode-coding-string f coding) "/") "/"))) - (dnd-handle-one-url window 'private - (concat - (if (eq system-type 'cygwin) - "file://" - "file:") - file-name))) + ;; FIXME: is the W32 build capable only of receiving a single file + ;; from each drop? + (dnd-handle-multiple-urls window (list (concat + (if (eq system-type 'cygwin) + "file://" + "file:") + file-name)) + 'private)) (defun w32-drag-n-drop (event &optional new-frame) "Edit the files listed in the drag-n-drop EVENT. diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el index b87fc97f8fd..eca1e93ba07 100644 --- a/lisp/x-dnd.el +++ b/lisp/x-dnd.el @@ -369,10 +369,9 @@ WINDOW is the window where the drop happened. STRING is the uri-list as a string. The URIs are separated by \\r\\n." (let ((uri-list (split-string string "[\0\r\n]" t)) retval) - (dolist (bf uri-list) - ;; If one URL is handled, treat as if the whole drop succeeded. - (let ((did-action (dnd-handle-one-url window action bf))) - (when did-action (setq retval did-action)))) + (let ((did-action (dnd-handle-multiple-urls window uri-list + action))) + (when did-action (setq retval did-action))) retval)) (defun x-dnd-handle-file-name (window action string) @@ -383,17 +382,21 @@ STRING is the file names as a string, separated by nulls." (coding (or file-name-coding-system default-file-name-coding-system)) retval) - (dolist (bf uri-list) - ;; If one URL is handled, treat as if the whole drop succeeded. - (if coding (setq bf (encode-coding-string bf coding))) - (let* ((file-uri (concat "file://" - (mapconcat 'url-hexify-string - (split-string bf "/") "/"))) - (did-action (dnd-handle-one-url window action file-uri))) - (when did-action (setq retval did-action)))) + (let ((did-action + (dnd-handle-multiple-urls + window action (mapcar + (lambda (item) + (when coding + (setq item (encode-coding-string item + coding))) + (concat "file://" + (mapconcat 'url-hexify-string + (split-string item "/") + "/"))) + uri-list)))) + (when did-action (setq retval did-action))) retval)) - (defun x-dnd-choose-type (types &optional known-types) "Choose which type we want to receive for the drop. TYPES are the types the source of the drop offers, a vector of type names diff --git a/test/lisp/dnd-tests.el b/test/lisp/dnd-tests.el index 9f97d739cec..342b6e49be4 100644 --- a/test/lisp/dnd-tests.el +++ b/test/lisp/dnd-tests.el @@ -33,6 +33,7 @@ (require 'tramp) (require 'select) (require 'ert-x) +(require 'browse-url) (defvar dnd-tests-selection-table nil "Alist of selection names to their values.") @@ -437,5 +438,100 @@ This function only tries to handle strings." (ignore-errors (delete-file normal-temp-file))))) + + +(defvar dnd-tests-list-1 '("file:///usr/openwin/include/pixrect/pr_impl.h" + "file:///usr/openwin/include/pixrect/pr_io.h") + "Sample data for tests concerning the treatment of drag-and-drop URLs.") + +(defvar dnd-tests-list-2 '("file:///usr/openwin/include/pixrect/pr_impl.h" + "file://remote/usr/openwin/include/pixrect/pr_io.h") + "Sample data for tests concerning the treatment of drag-and-drop URLs.") + +(defvar dnd-tests-list-3 (append dnd-tests-list-2 '("http://example.com")) + "Sample data for tests concerning the treatment of drag-and-drop URLs.") + +(defvar dnd-tests-list-4 (append dnd-tests-list-3 '("scheme1://foo.bar" + "scheme2://foo.bar")) + "Sample data for tests concerning the treatment of drag-and-drop URLs.") + +(defun dnd-tests-local-file-function (urls _action) + "Signal an error if URLS doesn't match `dnd-tests-list-1'. +ACTION is ignored. Return the symbol `copy' otherwise." + (should (equal urls dnd-tests-list-1)) + 'copy) + +(put 'dnd-tests-local-file-function 'dnd-multiple-handler t) + +(defun dnd-tests-remote-file-function (urls _action) + "Signal an error if URLS doesn't match `dnd-tests-list-2'. +ACTION is ignored. Return the symbol `copy' otherwise." + (should (equal urls dnd-tests-list-2)) + 'copy) + +(put 'dnd-tests-remote-file-function 'dnd-multiple-handler t) + +(defun dnd-tests-http-scheme-function (url _action) + "Signal an error if URLS doesn't match `dnd-tests-list-3''s third element. +ACTION is ignored. Return the symbol `private' otherwise." + (should (equal url (car (last dnd-tests-list-3)))) + 'private) + +(defun dnd-tests-browse-url-handler (url &rest _ignored) + "Verify URL is `dnd-tests-list-4''s fourth element." + (should (equal url (nth 3 dnd-tests-list-4)))) + +(put 'dnd-tests-browse-url-handler 'browse-url-browser-kind 'internal) + +(ert-deftest dnd-tests-receive-multiple-urls () + (let ((dnd-protocol-alist '(("^file:///" . dnd-tests-local-file-function) + ("^file:" . error) + ("^unrelated-scheme:" . error))) + (browse-url-handlers nil)) + ;; Check that the order of the alist is respected when the + ;; precedences of two handlers are equal. + (should (equal (dnd-handle-multiple-urls (selected-window) + (copy-sequence + dnd-tests-list-1) + 'copy) + 'copy)) + ;; Check that sorting handlers by precedence functions correctly. + (setq dnd-protocol-alist '(("^file:///" . error) + ("^file:" . dnd-tests-remote-file-function) + ("^unrelated-scheme:" . error))) + (should (equal (dnd-handle-multiple-urls (selected-window) + (copy-sequence + dnd-tests-list-2) + 'copy) + 'copy)) + ;; Check that multiple handlers can be called at once, and actions + ;; are properly "downgraded" to private when multiple handlers + ;; return inconsistent values. + (setq dnd-protocol-alist '(("^file:" . dnd-tests-remote-file-function) + ("^file:///" . error) + ("^http://" . dnd-tests-http-scheme-function))) + (should (equal (dnd-handle-multiple-urls (selected-window) + (copy-sequence + dnd-tests-list-3) + 'copy) + 'private)) + ;; Now verify that the function's documented fallback behavior + ;; functions correctly. Set browse-url-handlers to an association + ;; list incorporating a test function, then guarantee that is + ;; called. + (setq browse-url-handlers '(("^scheme1://" . dnd-tests-browse-url-handler))) + ;; Furthermore, guarantee the fifth argument of the test data is + ;; inserted, for no apposite handler exists. + (save-window-excursion + (set-window-buffer nil (get-buffer-create " *dnd-tests*")) + (set-buffer (get-buffer-create " *dnd-tests*")) + (erase-buffer) + (should (equal (dnd-handle-multiple-urls (selected-window) + (copy-sequence + dnd-tests-list-4) + 'copy) + 'private)) + (should (equal (buffer-string) (nth 4 dnd-tests-list-4)))))) + (provide 'dnd-tests) ;;; dnd-tests.el ends here