summaryrefslogtreecommitdiff
path: root/test/lisp/x-dnd-tests.el
diff options
context:
space:
mode:
authorStefan Monnier <monnier@iro.umontreal.ca>2022-09-25 16:15:16 -0400
committerStefan Monnier <monnier@iro.umontreal.ca>2022-09-25 16:15:16 -0400
commit650c20f1ca4e07591a727e1cfcc74b3363d15985 (patch)
tree85d11f6437cde22f410c25e0e5f71a3131ebd07d /test/lisp/x-dnd-tests.el
parent8869332684c2302b5ba1ead4568bbc7ba1c0183e (diff)
parent4b85ae6a24380fb67a3315eaec9233f17a872473 (diff)
downloademacs-650c20f1ca4e07591a727e1cfcc74b3363d15985.tar.gz
emacs-650c20f1ca4e07591a727e1cfcc74b3363d15985.tar.bz2
emacs-650c20f1ca4e07591a727e1cfcc74b3363d15985.zip
Merge 'master' into noverlay
Diffstat (limited to 'test/lisp/x-dnd-tests.el')
-rw-r--r--test/lisp/x-dnd-tests.el206
1 files changed, 206 insertions, 0 deletions
diff --git a/test/lisp/x-dnd-tests.el b/test/lisp/x-dnd-tests.el
new file mode 100644
index 00000000000..55994e9b724
--- /dev/null
+++ b/test/lisp/x-dnd-tests.el
@@ -0,0 +1,206 @@
+;;; dnd-tests.el --- Tests for X DND support -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2022 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Tests for stuff in x-dnd.el that doesn't require a window system.
+
+;;; Code:
+
+(require 'x-dnd)
+(require 'cl-lib)
+
+(when (display-graphic-p)
+ (error "This test cannot be run under X"))
+
+;; Dummy replacements.
+
+(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
+AgAAkwIAANkfAAALAB8AAABqAQAANgIAAJMCAADyAgAA2R8AANwfAADgHwAA4R8AAOIfAADjHwAA
+AQDQMAgCAQBQTggCAQCwe5IAAQDQmZIABgDyAgAA9wIAABcRAADgHwAAvSEAAI3AAAABAHC52AAB
+AGDY2AABAABq3QABAGBw3QAIAB8AAAA2AgAA8gIAANwfAADgHwAA4R8AAOIfAADjHwAAAQBwBOEA
+AQCACuEAAQAwLwUCAQDwPgUCAQBQxoQBAQCQ3YQBAQCQBYoBAQDACYoBAQCgMooBAQCgOIoBAQAf
+AAAAAQDATrcDAQAQ1LcDAQCw/sADAQAgBcEDAQBQt7oDAQAAUsIDAQCAc7wDAQAwerwDAQBAIKUE
+AQAALKUEAQDwfKUEAQDgg6UEAQCgjesEAQAAmusEAQCA7+sEAQCw9usECAAfAAAAagEAADYCAACT
+AgAABQMAAAYDAAATGwAAGhsAAA==")
+ "Predefined Motif targets table used to test the targets table parser.")
+
+(defconst x-dnd-tests-lispy-targets-table [[31 362 566 659 773 774] [6013584] [6017824]
+ [31 362 566 659 8153]
+ [31 362 566 659 754 8153 8156 8160 8161 8162 8163]
+ [34091216] [34098768] [9599920]
+ [9607632] [754 759 4375 8160 8637 49293]
+ [14203248] [14211168] [14510592]
+ [14512224] [31 566 754 8156 8160 8161 8162 8163]
+ [14746736] [14748288] [33894192] [33898224]
+ [25478736] [25484688] [25822608] [25823680]
+ [25834144] [25835680] [31] [62344896] [62379024]
+ [62979760] [62981408] [62568272] [63066624]
+ [62681984] [62683696] [77930560] [77933568]
+ [77954288] [77956064] [82546080] [82549248]
+ [82571136] [82572976] [31 362 566 659 773 774 6931 6938]]
+ "The expected result of parsing that targets table.")
+
+(defalias 'x-window-property
+ (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"))
+ x-dnd-tests-drag-window-xid)
+ ((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)
+ ((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.
+(ert-deftest x-dnd-tests-read-xm-targets-table ()
+ (should (equal (x-dnd-xm-read-targets-table nil)
+ x-dnd-tests-lispy-targets-table)))
+
+;;; XDS tests.
+
+(defvar x-dnd-xds-testing)
+
+(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"))
+ (x-dnd-xds-testing t))
+ ;; 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
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-10 07:06:13 +0000