207 lines
9.2 KiB
EmacsLisp
207 lines
9.2 KiB
EmacsLisp
;;; dnd-tests.el --- Tests for X DND support -*- lexical-binding: t; -*-
|
|
|
|
;; Copyright (C) 2022-2024 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
|