diff options
Diffstat (limited to 'test/lisp/dnd-tests.el')
| -rw-r--r-- | test/lisp/dnd-tests.el | 441 |
1 files changed, 441 insertions, 0 deletions
diff --git a/test/lisp/dnd-tests.el b/test/lisp/dnd-tests.el new file mode 100644 index 00000000000..67b660fc124 --- /dev/null +++ b/test/lisp/dnd-tests.el @@ -0,0 +1,441 @@ +;;; dnd-tests.el --- Tests for window system independent 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 dnd.el that doesn't require a window system. + +;; The drag API tests only check the behavior of the simplified drag +;; APIs in dnd.el. Actual drags are not performed during the +;; automated testing process (make check), but some of the tests can +;; also be run under X. + +;;; Code: + +(require 'dnd) +(require 'cl-lib) +(require 'tramp) +(require 'select) +(require 'ert-x) + +(defvar dnd-tests-selection-table nil + "Alist of selection names to their values.") + +(defvar x-treat-local-requests-remotely) +(defvar x-dnd-preserve-selection-data) + +;; Define some replacements for functions used by the drag-and-drop +;; code on X when running under something else. +(unless (eq window-system 'x) + ;; Substitute for x-begin-drag, which isn't present on all systems. + (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)) + ;; Verify that the action is valid and pretend the drag succeeded + ;; (by returning the action). + (cl-ecase action + (XdndActionCopy action) + (XdndActionMove action) + (XdndActionLink action) + ;; These two are not technically valid, but x-begin-drag accepts + ;; them anyway. + (XdndActionPrivate action) + (XdndActionAsk 'XdndActionPrivate)))) + + ;; This doesn't work during tests. + (defalias 'gui-set-selection + (lambda (type data) + (or (gui--valid-simple-selection-p data) + (and (vectorp data) + (let ((valid t)) + (dotimes (i (length data)) + (or (gui--valid-simple-selection-p (aref data i)) + (setq valid nil))) + valid)) + (signal 'error (list "invalid selection" data))) + (setf (alist-get type dnd-tests-selection-table) data)))) + +(declare-function x-get-selection-internal "xselect.c") + +(defun dnd-tests-verify-selection-data (type) + "Return the data of the drag-and-drop selection converted to TYPE." + (if (eq window-system 'x) + (let ((x-treat-local-requests-remotely t)) + (x-get-selection-internal 'XdndSelection type)) + (let* ((basic-value (cdr (assq 'XdndSelection + dnd-tests-selection-table))) + (local-value (if (stringp basic-value) + (or (get-text-property 0 type basic-value) + basic-value) + basic-value)) + (converter-list (cdr (assq type selection-converter-alist))) + (converter (if (consp converter-list) + (cdr converter-list) + converter-list))) + (if (and local-value converter) + (funcall converter 'XdndSelection type local-value) + (error "No selection converter or local value: %s" type))))) + +(defun dnd-tests-remote-accessible-p () + "Return if a test involving remote files can proceed." + (ignore-errors + (and + (file-remote-p ert-remote-temporary-file-directory) + (file-directory-p ert-remote-temporary-file-directory) + (file-writable-p ert-remote-temporary-file-directory)))) + +(defun dnd-tests-make-temp-name () + "Return a temporary remote file name for test. +The temporary file is not created." + (expand-file-name (make-temp-name "dnd-test-remote") + ert-remote-temporary-file-directory)) + +(defun dnd-tests-parse-tt-netfile (netfile) + "Parse NETFILE and return its components. +NETFILE should be a canonicalized ToolTalk file name. +Return a list of its hostname, real path, and local path." + (save-match-data + (when (string-match (concat "HOST=0-\\([[:digit:]]+\\),RPATH=\\([[:digit:]]+\\)-" + "\\([[:digit:]]+\\),LPATH=\\([[:digit:]]+\\)-" + "\\([[:digit:]]+\\)\\(:\\)") + netfile) + (let ((beg (match-end 6))) + (list (substring netfile beg + (+ beg 1 + (string-to-number (match-string 1 netfile)))) + (substring netfile + (+ beg + (string-to-number (match-string 2 netfile))) + (+ beg 1 + (string-to-number (match-string 3 netfile)))) + (substring netfile + (+ beg + (string-to-number (match-string 4 netfile))) + (+ beg 1 + (string-to-number (match-string 5 netfile))))))))) + +(defun dnd-tests-extract-selection-data (selection expect-cons) + "Return the selection data in SELECTION. +SELECTION can either be the value of `gui-get-selection', or the +return value of a selection converter. + +If EXPECT-CONS, then expect SELECTION to be a cons (when not +running under X). + +This function only tries to handle strings." + (when (and expect-cons (not (eq window-system 'x))) + (should (and (consp selection) + (stringp (cdr selection))))) + (if (stringp selection) + selection + (cdr selection))) + +(ert-deftest dnd-tests-begin-text-drag () + ;; When running this test under X, please make sure to drop onto a + ;; program with reasonably correct behavior, such as dtpad, gedit, + ;; or Mozilla. + ;; ASCII Latin-1 UTF-8 + (let ((test-text "hello, everyone! sæl öllsömul! всем привет") + (x-dnd-preserve-selection-data t)) + ;; Verify that dragging works. + (should (eq (dnd-begin-text-drag test-text) 'copy)) + (should (eq (dnd-begin-text-drag test-text nil 'move) 'move)) + ;; Verify that the important data types are converted correctly. + (let ((string-data (dnd-tests-verify-selection-data 'STRING))) + ;; Check that the Latin-1 target is converted correctly. + (should (equal (dnd-tests-extract-selection-data string-data t) + (encode-coding-string test-text + 'iso-8859-1)))) + ;; And that UTF8_STRING and the Xdnd UTF8 string are as well. + (let* ((string-data (dnd-tests-verify-selection-data + 'UTF8_STRING)) + (string-data-1 (dnd-tests-verify-selection-data + 'text/plain\;charset=utf-8)) + (extracted-1 (dnd-tests-extract-selection-data string-data-1 t)) + (extracted (dnd-tests-extract-selection-data string-data t))) + (should (and (stringp extracted) (stringp extracted-1))) + (should (equal extracted extracted))) + ;; Now check text/plain. + (let ((string-data (dnd-tests-verify-selection-data + 'text/plain))) + (should (equal (dnd-tests-extract-selection-data string-data t) + (encode-coding-string test-text 'ascii)))))) + +(ert-deftest dnd-tests-begin-file-drag () + ;; These tests also involve handling remote file names. + (skip-unless (and (dnd-tests-remote-accessible-p) + ;; TODO: make these tests work under X. + (not (eq window-system 'x)))) + (let ((normal-temp-file (expand-file-name (make-temp-name "dnd-test") + temporary-file-directory)) + (normal-multibyte-file (expand-file-name + (make-temp-name "тест-на-перетаскивание") + temporary-file-directory)) + (remote-temp-file (dnd-tests-make-temp-name)) + (x-dnd-preserve-selection-data t)) + ;; Touch those files if they don't exist. + (unless (file-exists-p normal-temp-file) + (write-region "" 0 normal-temp-file)) + (unless (file-exists-p normal-multibyte-file) + (write-region "" 0 normal-multibyte-file)) + (unless (file-exists-p remote-temp-file) + (write-region "" 0 remote-temp-file)) + (unwind-protect + (progn + ;; Now test dragging a normal file. + (should (eq (dnd-begin-file-drag normal-temp-file) 'copy)) + ;; Test that the selection data is correct. + (let ((uri-list-data (cdr (dnd-tests-verify-selection-data 'text/uri-list))) + (username-data (dnd-tests-verify-selection-data 'text/x-xdnd-username)) + (file-name-data (cdr (dnd-tests-verify-selection-data 'FILE_NAME))) + (host-name-data (cdr (dnd-tests-verify-selection-data 'HOST_NAME))) + (netfile-data (cdr (dnd-tests-verify-selection-data '_DT_NETFILE)))) + ;; Check if the URI list is formatted correctly. + (let* ((split-uri-list (split-string uri-list-data "[\0\r\n]" t)) + (decoded (dnd-get-local-file-name (car split-uri-list)))) + (should (equal decoded normal-temp-file))) + ;; Test that the username reported is correct. + (should (equal username-data (user-real-login-name))) + ;; Test that the file name data is correct. + (let* ((split-file-names (split-string file-name-data "\0")) + (file-name (car split-file-names))) + ;; Make sure there are no extra leading or trailing NULL bytes. + (should (and split-file-names (null (cdr split-file-names)))) + ;; Make sure the file name is encoded correctly; + (should-not (multibyte-string-p file-name)) + ;; Make sure decoding the file name results in the + ;; originals. + (should (equal (decode-coding-string file-name + (or file-name-coding-system + default-file-name-coding-system)) + normal-temp-file)) + ;; Also make sure the hostname is correct. + (should (equal host-name-data (system-name)))) + ;; Check that the netfile hostname, rpath and lpath are correct. + (let ((parsed (dnd-tests-parse-tt-netfile netfile-data)) + (filename (encode-coding-string normal-temp-file + (or file-name-coding-system + default-file-name-coding-system)))) + (should (equal (nth 0 parsed) (system-name))) + (should (equal (nth 1 parsed) filename)) + (should (equal (nth 2 parsed) filename)))) + ;; And the remote file. + (should (eq (dnd-begin-file-drag remote-temp-file) 'copy)) + ;; Test that the remote file was added to the list of files + ;; to remove later. + (should dnd-last-dragged-remote-file) + ;; Make sure the appropriate hook is added so the remote + ;; files are removed when Emacs exits. + (should (memq #'dnd-remove-last-dragged-remote-file + kill-emacs-hook)) + ;; Test that the remote file was removed. + (should (progn + (dnd-begin-file-drag normal-temp-file) + (not dnd-last-dragged-remote-file))) + ;; Make sure the remote file removal hook was deleted. + (should-not (memq #'dnd-remove-last-dragged-remote-file + kill-emacs-hook)) + ;; Test that links to remote files can't be created. + (should-error (dnd-begin-file-drag remote-temp-file nil 'link)) + ;; Test dragging a file with a multibyte filename. + (should (eq (dnd-begin-file-drag normal-multibyte-file) 'copy)) + ;; Test that the ToolTalk filename is encodes and decodes correctly. + (let* ((netfile-data (cdr (dnd-tests-verify-selection-data '_DT_NETFILE))) + (parsed (dnd-tests-parse-tt-netfile netfile-data)) + (filename (encode-coding-string normal-multibyte-file + (or file-name-coding-system + default-file-name-coding-system)))) + (should (equal (nth 0 parsed) (system-name))) + (should (equal (nth 1 parsed) filename)) + (should (equal (nth 2 parsed) filename)))) + (delete-file normal-temp-file) + (delete-file normal-multibyte-file) + (delete-file remote-temp-file)))) + +(ert-deftest dnd-tests-begin-drag-files () + (skip-unless (and (dnd-tests-remote-accessible-p) + ;; TODO: make these tests work under X. + (not (eq window-system 'x)))) + (let ((normal-temp-file (expand-file-name (make-temp-name "dnd-test") + temporary-file-directory)) + (normal-temp-file-1 (expand-file-name (make-temp-name "dnd-test") + temporary-file-directory)) + (remote-temp-file (dnd-tests-make-temp-name)) + (nonexistent-local-file + (expand-file-name (make-temp-name "dnd-test") + temporary-file-directory)) + (nonexistent-remote-file (dnd-tests-make-temp-name)) + (nonexistent-remote-file-1 (dnd-tests-make-temp-name)) + (x-dnd-preserve-selection-data t)) + ;; Touch those files if they don't exist. + (unless (file-exists-p normal-temp-file) + (write-region "" 0 normal-temp-file)) + (unless (file-exists-p normal-temp-file-1) + (write-region "" 0 normal-temp-file)) + (unless (file-exists-p remote-temp-file) + (write-region "" 0 remote-temp-file)) + (ignore-errors + (delete-file nonexistent-local-file) + (delete-file nonexistent-remote-file) + (delete-file nonexistent-remote-file-1)) + (unwind-protect + (progn + ;; Now test dragging a normal file and a remote file. + (should (eq (dnd-begin-drag-files (list normal-temp-file + remote-temp-file)) + 'copy)) + ;; Test that the remote file produced was added to the list + ;; of files to remove upon the next call. + (should dnd-last-dragged-remote-file) + ;; Make sure the appropriate hook is added so the remote + ;; files are removed when Emacs exits. + (should (memq #'dnd-remove-last-dragged-remote-file + kill-emacs-hook)) + ;; Two local files at the same time. + (should (eq (dnd-begin-drag-files (list normal-temp-file + normal-temp-file-1)) + 'copy)) + ;; Test that the remote files were removed. + (should-not dnd-last-dragged-remote-file) + ;; And so was the hook. + (should-not (memq #'dnd-remove-last-dragged-remote-file + kill-emacs-hook)) + ;; Test the selection data is correct. + (let ((uri-list-data (cdr (dnd-tests-verify-selection-data 'text/uri-list))) + (username-data (dnd-tests-verify-selection-data 'text/x-xdnd-username)) + (file-name-data (cdr (dnd-tests-verify-selection-data 'FILE_NAME))) + (host-name-data (cdr (dnd-tests-verify-selection-data 'HOST_NAME)))) + ;; Check if the URI list is formatted correctly. + (let* ((split-uri-list (split-string uri-list-data "[\0\r\n]" t)) + (decoded (mapcar #'dnd-get-local-file-name split-uri-list))) + (should (equal (car decoded) normal-temp-file)) + (should (equal (cadr decoded) normal-temp-file-1))) + ;; Test that the username reported is correct. + (should (equal username-data (user-real-login-name))) + ;; Test that the file name data is correct. + (let ((split-file-names (split-string file-name-data "\0"))) + ;; Make sure there are no extra leading or trailing NULL bytes. + (should (equal (length split-file-names) 2)) + ;; Make sure all file names are encoded correctly; + (dolist (name split-file-names) + (should-not (multibyte-string-p name))) + ;; Make sure decoding the file names result in the + ;; originals. + (should (equal (decode-coding-string (car split-file-names) + (or file-name-coding-system + default-file-name-coding-system)) + normal-temp-file)) + (should (equal (decode-coding-string (cadr split-file-names) + (or file-name-coding-system + default-file-name-coding-system)) + normal-temp-file-1)) + ;; Also make sure the hostname is correct. + (should (equal host-name-data (system-name))))) + ;; Multiple local files with some remote files that will + ;; fail, and some that won't. + (should (and (eq (dnd-begin-drag-files (list normal-temp-file + remote-temp-file + remote-temp-file + nonexistent-remote-file + normal-temp-file-1 + nonexistent-remote-file-1)) + 'copy) + ;; Make sure exactly two valid remote files + ;; were downloaded. + (eq (length dnd-last-dragged-remote-file) 2))) + ;; Make sure the appropriate hook is added so the remote + ;; files are removed when Emacs exits. + (should (memq #'dnd-remove-last-dragged-remote-file + kill-emacs-hook)) + ;; Make sure links can't be created to remote files. + (should-error (dnd-begin-drag-files (list normal-temp-file + remote-temp-file + normal-temp-file-1) + nil 'link)) + ;; And that they can to normal files. + (should (eq (dnd-begin-drag-files (list normal-temp-file + normal-temp-file-1) + nil 'link) + 'link)) + ;; Make sure the remote file removal hook was deleted. + (should-not (memq #'dnd-remove-last-dragged-remote-file + kill-emacs-hook)) + ;; Make sure you can't drag an empty list of files. + (should-error (dnd-begin-drag-files nil)) + ;; And when all remote files are inaccessible. + (should-error (dnd-begin-drag-files (list nonexistent-remote-file + nonexistent-remote-file-1)))) + (delete-file normal-temp-file) + (delete-file normal-temp-file-1) + (delete-file remote-temp-file)))) + +(ert-deftest dnd-tests-get-local-file-uri () + (should (equal (dnd-get-local-file-uri "file://localhost/path/to/foo") + "file:///path/to/foo")) + (should (equal (dnd-get-local-file-uri + (format "file://%s/path/to/" (system-name))) + "file:///path/to/")) + (should-not (dnd-get-local-file-uri "file://some-remote-host/path/to/foo")) + (should-not (dnd-get-local-file-uri "file:///path/to/foo"))) + +(ert-deftest dnd-tests-open-remote-url () + ;; Expensive test to make sure opening an FTP URL during + ;; drag-and-drop works. + :tags '(:expensive-test) + ;; Don't run if there is no ftp client. + (skip-unless (executable-find "ftp")) + ;; Don't run this test if the FTP server isn't reachable. + (skip-unless (and (fboundp 'network-lookup-address-info) + (network-lookup-address-info "ftp.gnu.org"))) + ;; Make sure bug#56078 doesn't happen again. + (let ((url "ftp://anonymous@ftp.gnu.org/") + ;; This prints a bunch of annoying spaces to stdout. + (inhibit-message t)) + (should (prog1 t (dnd-open-remote-url url 'private))))) + +(ert-deftest dnd-tests-direct-save () + ;; This test just verifies that a direct save works; the window + ;; system specific test is in x-dnd-tests.el. When running this + ;; interactively, keep in mind that there are only two file managers + ;; which are known to implement XDS correctly: System G (see + ;; http://nps-systemg.sourceforge.net), and Emacs itself. GTK file + ;; managers such as Nautilus will not work, since they prefer the + ;; `text/uri-list' selection target to `XdndDirectSave0', contrary + ;; to the XDS specification. + (let ((window-system window-system) + (normal-temp-file (expand-file-name (make-temp-name "dnd-test") + temporary-file-directory))) + (unwind-protect + (progn + (unless (file-exists-p normal-temp-file) + (write-region "" 0 normal-temp-file)) + (unless (eq window-system 'x) + ;; Use a window system that isn't X, since we only want to test + ;; the fallback code when run non-interactively. + (setq window-system 'haiku)) + (should (eq (dnd-direct-save normal-temp-file + (make-temp-name "target-file-name")) + 'copy))) + (ignore-errors + (delete-file normal-temp-file))))) + +(provide 'dnd-tests) +;;; dnd-tests.el ends here |