mirror of
git://git.sv.gnu.org/emacs.git
synced 2026-02-16 17:24:23 +00:00
3237d1d6b6
* lisp/dnd.el (dnd-begin-file-drag, dnd-begin-drag-files): Fix type of `x-xdnd-username'. * lisp/select.el (selection-converter-alist): Fix declaration of _DT_NETFILE converter. * test/lisp/dnd-tests.el (dnd-tests-verify-selection-data): Handle "compound" selection converters. (dnd-tests-parse-tt-netfile): New function. (dnd-tests-begin-file-drag, dnd-tests-begin-drag-files): Verify validity of file selection data.
345 lines
17 KiB
EmacsLisp
345 lines
17 KiB
EmacsLisp
;;; 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.
|
|
|
|
;;; Code:
|
|
|
|
(require 'dnd)
|
|
(require 'cl-lib)
|
|
(require 'tramp)
|
|
(require 'select)
|
|
|
|
;; This code was taken from tramp-tests.el: perhaps some of it isn't
|
|
;; strictly necessary.
|
|
(defconst dnd-tests-temporary-file-directory
|
|
(cond
|
|
((getenv "REMOTE_TEMPORARY_FILE_DIRECTORY"))
|
|
((eq system-type 'windows-nt) null-device)
|
|
(t (add-to-list
|
|
'tramp-methods
|
|
'("mock"
|
|
(tramp-login-program "sh")
|
|
(tramp-login-args (("-i")))
|
|
(tramp-remote-shell "/bin/sh")
|
|
(tramp-remote-shell-args ("-c"))
|
|
(tramp-connection-timeout 10)))
|
|
(add-to-list
|
|
'tramp-default-host-alist
|
|
`("\\`mock\\'" nil ,(system-name)))
|
|
;; Emacs's Makefile sets $HOME to a nonexistent value. Needed
|
|
;; in batch mode only, therefore.
|
|
(unless (and (null noninteractive) (file-directory-p "~/"))
|
|
(setenv "HOME" temporary-file-directory))
|
|
(format "/mock::%s" temporary-file-directory)))
|
|
"Temporary directory for drag-and-drop tests involving remote files.")
|
|
|
|
(defvar dnd-tests-selection-table nil
|
|
"Alist of selection names to their values.")
|
|
|
|
;; 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)))
|
|
|
|
(defun dnd-tests-verify-selection-data (type)
|
|
"Return the data of the drag-and-drop selection converted to 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 dnd-tests-temporary-file-directory)
|
|
(file-directory-p dnd-tests-temporary-file-directory)
|
|
(file-writable-p dnd-tests-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")
|
|
dnd-tests-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)))))))))
|
|
|
|
(ert-deftest dnd-tests-begin-text-drag ()
|
|
;; ASCII Latin-1 UTF-8
|
|
(let ((test-text "hello, everyone! sæl öllsömul! всем привет"))
|
|
;; 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 (cdr string-data)
|
|
(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 (cdr (dnd-tests-verify-selection-data
|
|
'text/plain\;charset=utf-8))))
|
|
(should (and (stringp (cdr string-data))
|
|
(stringp string-data-1)))
|
|
(should (equal (cdr string-data) string-data-1)))
|
|
;; Now check text/plain.
|
|
(let ((string-data (dnd-tests-verify-selection-data
|
|
'text/plain)))
|
|
(should (equal (cdr string-data)
|
|
(encode-coding-string test-text 'ascii))))))
|
|
|
|
(ert-deftest dnd-tests-begin-file-drag ()
|
|
;; These tests also involve handling remote file names.
|
|
(skip-unless (dnd-tests-remote-accessible-p))
|
|
(let ((normal-temp-file (expand-file-name (make-temp-name "dnd-test")
|
|
temporary-file-directory))
|
|
(remote-temp-file (dnd-tests-make-temp-name)))
|
|
;; 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 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)
|
|
;; Test that the remote file was removed.
|
|
(should (progn
|
|
(dnd-begin-file-drag normal-temp-file)
|
|
(not dnd-last-dragged-remote-file)))
|
|
;; Test that links to remote files can't be created.
|
|
(should-error (dnd-begin-file-drag remote-temp-file nil 'link)))
|
|
(delete-file normal-temp-file)
|
|
(delete-file remote-temp-file))))
|
|
|
|
(ert-deftest dnd-tests-begin-drag-files ()
|
|
(skip-unless (dnd-tests-remote-accessible-p))
|
|
(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)))
|
|
;; 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)
|
|
;; 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)
|
|
;; 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 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 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")))
|
|
|
|
(provide 'dnd-tests)
|
|
;;; dnd-tests.el ends here
|