From: Po Lu Date: Fri, 1 Jul 2022 03:31:25 +0000 (+0800) Subject: Add tests for XDS protocol support X-Git-Tag: emacs-29.0.90~1447^2~1313 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=23df6df775c7cb88534ea310287ff9b057cc98f9;p=emacs.git Add tests for XDS protocol support * test/lisp/x-dnd-tests.el (x-dnd-tests-xds-property-value): New variable. (x-window-property): Handle new kind of window property. (x-dnd-tests-xds-target-dir, x-dnd-tests-xds-name) (x-dnd-tests-xds-include-hostname): New variables. (x-dnd-tests-call-xds-converter): New function. (x-begin-drag, x-change-window-property): (x-delete-window-property): New replacement functions. (x-dnd-tests-do-direct-save-internal): New function. (x-dnd-tests-do-direct-save): New test. --- diff --git a/test/lisp/x-dnd-tests.el b/test/lisp/x-dnd-tests.el index 35cda3b10a0..8856be79ebc 100644 --- a/test/lisp/x-dnd-tests.el +++ b/test/lisp/x-dnd-tests.el @@ -24,6 +24,7 @@ ;;; Code: (require 'x-dnd) +(require 'cl-lib) (when (display-graphic-p) (error "This test cannot be run under X")) @@ -33,6 +34,9 @@ (defconst x-dnd-tests-drag-window-xid 3948573 "XID of the drag window returned during the test.") +(defvar x-dnd-tests-xds-property-value nil + "The value of the `XdndDirectSave0' window property.") + (defconst x-dnd-tests-targets-table (base64-decode-string "bAArAKIBAAAGAB8AAABqAQAANgIAAJMCAAAFAwAABgMAAAEAkMJbAAEAINNbAAUAHwAAAGoBAAA2 @@ -62,7 +66,7 @@ AgAABQMAAAYDAAATGwAAGhsAAA==") "The expected result of parsing that targets table.") (defalias 'x-window-property - (lambda (prop &optional _frame type window-id _delete-p _vector-ret-p) + (lambda (prop &optional _frame type window-id delete-p _vector-ret-p) (cond ((and (equal prop "_MOTIF_DRAG_WINDOW") (zerop window-id) (equal type "WINDOW")) @@ -70,7 +74,13 @@ AgAABQMAAAYDAAATGwAAGhsAAA==") ((and (equal prop "_MOTIF_DRAG_TARGETS") (equal type "_MOTIF_DRAG_TARGETS") (equal window-id x-dnd-tests-drag-window-xid)) - x-dnd-tests-targets-table)))) + x-dnd-tests-targets-table) + ((and (equal prop "XdndDirectSave0") + (or (equal type "text/plain") + (equal type "AnyPropertyType"))) + (prog1 x-dnd-tests-xds-property-value + (when delete-p + (setq x-dnd-tests-xds-property-value nil))))))) ;; This test also serves to exercise most of the Motif value ;; extraction code. @@ -78,5 +88,116 @@ AgAABQMAAAYDAAATGwAAGhsAAA==") (should (equal (x-dnd-xm-read-targets-table nil) x-dnd-tests-lispy-targets-table))) +;;; XDS tests. + +(defvar x-dnd-tests-xds-target-dir nil + "The name of the target directory where the file will be saved.") + +(defvar x-dnd-tests-xds-name nil + "The name that the dragged file should be saved under.") + +(defvar x-dnd-tests-xds-include-hostname nil + "Whether or not to include the hostname inside the XDS URI.") + +(defun x-dnd-tests-call-xds-converter () + "Look up the XDS selection converter and call it. +Return the result of the selection." + (let ((conv (cdr (assq 'XdndDirectSave0 + selection-converter-alist)))) + (should (functionp conv)) + (funcall conv 'XdndDirectSave0 'XdndDirectSave0 nil))) + +(defalias 'x-begin-drag + (lambda (_targets &optional action frame &rest _) + ;; Verify that frame is either nil or a valid frame. + (when (and frame (not (frame-live-p frame))) + (signal 'wrong-type-argument frame)) + (prog1 'XdndActionDirectSave + ;; Verify that the action is `XdndActionDirectSave'. + (should (eq action 'XdndActionDirectSave)) + ;; Set the property value to the URI of the new file. + (should (and (stringp x-dnd-tests-xds-property-value) + (not (multibyte-string-p x-dnd-tests-xds-property-value)))) + (let ((uri (if x-dnd-tests-xds-include-hostname + (format "file://%s%s" (system-name) + (expand-file-name x-dnd-tests-xds-property-value + x-dnd-tests-xds-target-dir)) + (concat "file:///" (expand-file-name x-dnd-tests-xds-property-value + x-dnd-tests-xds-target-dir))))) + (setq x-dnd-tests-xds-property-value + (encode-coding-string (url-encode-url uri) + 'raw-text))) + ;; Convert the selection and verify its success. + (should (equal (x-dnd-tests-call-xds-converter) + '(STRING . "S")))))) + +(defalias 'x-change-window-property + (lambda (prop value &optional _frame type format outer-p _window-id) + ;; Check that the properties are the right type. + (should (equal prop "XdndDirectSave0")) + (should (equal value (encode-coding-string + x-dnd-tests-xds-name + (or file-name-coding-system + default-file-name-coding-system)))) + (should (equal type "text/plain")) + (should (equal format 8)) + (should (not outer-p)) + (setq x-dnd-tests-xds-property-value value))) + +(defalias 'x-delete-window-property + (lambda (&rest _args) + ;; This function shouldn't ever be reached during XDS. + (setq x-dnd-tests-xds-property-value nil))) + +(defun x-dnd-tests-do-direct-save-internal (include-hostname) + "Test the behavior of `x-dnd-do-direct-save'. +Make it perform a direct save to a randomly generated directory, +and check that the file exists. If INCLUDE-HOSTNAME, include the +hostname in the target URI." + (let ((x-dnd-tests-xds-include-hostname include-hostname) + (x-dnd-tests-xds-target-dir + (file-name-as-directory (expand-file-name + (make-temp-name "x-dnd-test") + temporary-file-directory))) + (original-file (expand-file-name + (make-temp-name "x-dnd-test") + temporary-file-directory)) + (x-dnd-tests-xds-name (make-temp-name "x-dnd-test-target"))) + ;; The call to `gui-set-selection' is only used for providing the + ;; conventional `text/uri-list' target and can be ignored. + (cl-flet ((gui-set-selection #'ignore)) + (unwind-protect + (progn + ;; Touch `original-file' if it doesn't exist. + (unless (file-exists-p original-file) + (write-region "" 0 original-file)) + ;; Create `x-dnd-tests-xds-target-dir'. + (make-directory x-dnd-tests-xds-target-dir) + ;; Start the direct save and verify it returns the correct action. + (should (eq (x-dnd-do-direct-save original-file + x-dnd-tests-xds-name + nil nil) + 'XdndActionDirectSave)) + ;; Now verify that the new file exists. + (should (file-exists-p + (expand-file-name x-dnd-tests-xds-name + x-dnd-tests-xds-target-dir))) + ;; The XDS protocol makes very clear that the window + ;; property must be deleted after the drag-and-drop + ;; operation completes. + (should (not x-dnd-tests-xds-property-value))) + ;; Clean up after ourselves. + (ignore-errors + (delete-file original-file)) + (ignore-errors + (delete-directory x-dnd-tests-xds-target-dir t)))))) + +(ert-deftest x-dnd-tests-do-direct-save () + ;; TODO: add tests for application/octet-stream transfer. + (x-dnd-tests-do-direct-save-internal nil) + ;; Test with both kinds of file: URIs, since different programs + ;; generate different kinds. + (x-dnd-tests-do-direct-save-internal t)) + (provide 'x-dnd-tests) ;;; x-dnd-tests.el ends here