mirror of
https://github.com/masscollaborationlabs/emacs.git
synced 2025-07-11 14:40:50 +00:00
ecf08f0621
dc4e6b1329; Update copyright years in more files64b3777631; Run set-copyright from admin.el8e1c56ae46; Add 2024 to copyright years # Conflicts: # doc/misc/modus-themes.org # doc/misc/texinfo.tex # etc/NEWS # etc/refcards/ru-refcard.tex # etc/themes/modus-operandi-theme.el # etc/themes/modus-themes.el # etc/themes/modus-vivendi-theme.el # lib/alloca.in.h # lib/binary-io.h # lib/c-ctype.h # lib/c-strcasecmp.c # lib/c-strncasecmp.c # lib/careadlinkat.c # lib/cloexec.c # lib/close-stream.c # lib/diffseq.h # lib/dup2.c # lib/filemode.h # lib/fpending.c # lib/fpending.h # lib/fsusage.c # lib/getgroups.c # lib/getloadavg.c # lib/gettext.h # lib/gettime.c # lib/gettimeofday.c # lib/group-member.c # lib/malloc.c # lib/md5-stream.c # lib/md5.c # lib/md5.h # lib/memmem.c # lib/memrchr.c # lib/nanosleep.c # lib/save-cwd.h # lib/sha1.c # lib/sig2str.c # lib/stdlib.in.h # lib/strtoimax.c # lib/strtol.c # lib/strtoll.c # lib/time_r.c # lib/xalloc-oversized.h # lisp/auth-source-pass.el # lisp/emacs-lisp/lisp-mnt.el # lisp/emacs-lisp/timer.el # lisp/info-look.el # lisp/jit-lock.el # lisp/loadhist.el # lisp/mail/rmail.el # lisp/net/ntlm.el # lisp/net/webjump.el # lisp/progmodes/asm-mode.el # lisp/progmodes/project.el # lisp/progmodes/sh-script.el # lisp/textmodes/flyspell.el # lisp/textmodes/reftex-toc.el # lisp/textmodes/reftex.el # lisp/textmodes/tex-mode.el # lisp/url/url-gw.el # m4/alloca.m4 # m4/clock_time.m4 # m4/d-type.m4 # m4/dirent_h.m4 # m4/dup2.m4 # m4/euidaccess.m4 # m4/fchmodat.m4 # m4/filemode.m4 # m4/fsusage.m4 # m4/getgroups.m4 # m4/getloadavg.m4 # m4/getrandom.m4 # m4/gettime.m4 # m4/gettimeofday.m4 # m4/gnulib-common.m4 # m4/group-member.m4 # m4/inttypes.m4 # m4/malloc.m4 # m4/manywarnings.m4 # m4/mempcpy.m4 # m4/memrchr.m4 # m4/mkostemp.m4 # m4/mktime.m4 # m4/nproc.m4 # m4/nstrftime.m4 # m4/pathmax.m4 # m4/pipe2.m4 # m4/pselect.m4 # m4/pthread_sigmask.m4 # m4/readlink.m4 # m4/realloc.m4 # m4/sig2str.m4 # m4/ssize_t.m4 # m4/stat-time.m4 # m4/stddef_h.m4 # m4/stdint.m4 # m4/stdio_h.m4 # m4/stdlib_h.m4 # m4/stpcpy.m4 # m4/strnlen.m4 # m4/strtoimax.m4 # m4/strtoll.m4 # m4/time_h.m4 # m4/timegm.m4 # m4/timer_time.m4 # m4/timespec.m4 # m4/unistd_h.m4 # m4/warnings.m4 # nt/configure.bat # nt/preprep.c # test/lisp/register-tests.el
599 lines
29 KiB
EmacsLisp
599 lines
29 KiB
EmacsLisp
;;; dnd-tests.el --- Tests for window system independent 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 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)
|
||
(require 'browse-url)
|
||
|
||
(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-1)))
|
||
;; 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
|
||
;; https://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)))))
|
||
|
||
|
||
|
||
(defvar dnd-tests-list-1 '("file:///usr/openwin/include/pixrect/pr_impl.h"
|
||
"file:///usr/openwin/include/pixrect/pr_io.h")
|
||
"Sample data for tests concerning the treatment of drag-and-drop URLs.")
|
||
|
||
(defvar dnd-tests-list-2 '("file:///usr/openwin/include/pixrect/pr_impl.h"
|
||
"file://remote/usr/openwin/include/pixrect/pr_io.h")
|
||
"Sample data for tests concerning the treatment of drag-and-drop URLs.")
|
||
|
||
(defvar dnd-tests-list-3 (append dnd-tests-list-2 '("http://example.com"))
|
||
"Sample data for tests concerning the treatment of drag-and-drop URLs.")
|
||
|
||
(defvar dnd-tests-list-4 (append dnd-tests-list-3 '("scheme1://foo.bar"
|
||
"scheme2://foo.bar"))
|
||
"Sample data for tests concerning the treatment of drag-and-drop URLs.")
|
||
|
||
(defun dnd-tests-local-file-function (urls _action)
|
||
"Signal an error if URLS doesn't match `dnd-tests-list-1'.
|
||
ACTION is ignored. Return the symbol `copy' otherwise."
|
||
(should (equal urls dnd-tests-list-1))
|
||
'copy)
|
||
|
||
(put 'dnd-tests-local-file-function 'dnd-multiple-handler t)
|
||
|
||
(defun dnd-tests-remote-file-function (urls _action)
|
||
"Signal an error if URLS doesn't match `dnd-tests-list-2'.
|
||
ACTION is ignored. Return the symbol `copy' otherwise."
|
||
(should (equal urls dnd-tests-list-2))
|
||
'copy)
|
||
|
||
(put 'dnd-tests-remote-file-function 'dnd-multiple-handler t)
|
||
|
||
(defun dnd-tests-http-scheme-function (url _action)
|
||
"Signal an error if URLS doesn't match `dnd-tests-list-3''s third element.
|
||
ACTION is ignored. Return the symbol `private' otherwise."
|
||
(should (equal url (car (last dnd-tests-list-3))))
|
||
'private)
|
||
|
||
(defun dnd-tests-browse-url-handler (url &rest _ignored)
|
||
"Verify URL is `dnd-tests-list-4''s fourth element."
|
||
(should (equal url (nth 3 dnd-tests-list-4))))
|
||
|
||
(put 'dnd-tests-browse-url-handler 'browse-url-browser-kind 'internal)
|
||
|
||
(ert-deftest dnd-tests-receive-multiple-urls ()
|
||
(let ((dnd-protocol-alist '(("^file:///" . dnd-tests-local-file-function)
|
||
("^file:" . error)
|
||
("^unrelated-scheme:" . error)))
|
||
(browse-url-handlers nil))
|
||
;; Check that the order of the alist is respected when the
|
||
;; precedences of two handlers are equal.
|
||
(should (equal (dnd-handle-multiple-urls (selected-window)
|
||
(copy-sequence
|
||
dnd-tests-list-1)
|
||
'copy)
|
||
'copy))
|
||
;; Check that sorting handlers by precedence functions correctly.
|
||
(setq dnd-protocol-alist '(("^file:///" . error)
|
||
("^file:" . dnd-tests-remote-file-function)
|
||
("^unrelated-scheme:" . error)))
|
||
(should (equal (dnd-handle-multiple-urls (selected-window)
|
||
(copy-sequence
|
||
dnd-tests-list-2)
|
||
'copy)
|
||
'copy))
|
||
;; Check that multiple handlers can be called at once, and actions
|
||
;; are properly "downgraded" to private when multiple handlers
|
||
;; return inconsistent values.
|
||
(setq dnd-protocol-alist '(("^file:" . dnd-tests-remote-file-function)
|
||
("^file:///" . error)
|
||
("^http://" . dnd-tests-http-scheme-function)))
|
||
(should (equal (dnd-handle-multiple-urls (selected-window)
|
||
(copy-sequence
|
||
dnd-tests-list-3)
|
||
'copy)
|
||
'private))
|
||
;; Now verify that the function's documented fallback behavior
|
||
;; functions correctly. Set browse-url-handlers to an association
|
||
;; list incorporating a test function, then guarantee that is
|
||
;; called.
|
||
(setq browse-url-handlers '(("^scheme1://" . dnd-tests-browse-url-handler)))
|
||
;; Furthermore, guarantee the fifth argument of the test data is
|
||
;; inserted, for no apposite handler exists.
|
||
(save-window-excursion
|
||
(set-window-buffer nil (get-buffer-create " *dnd-tests*"))
|
||
(set-buffer (get-buffer-create " *dnd-tests*"))
|
||
(erase-buffer)
|
||
(should (equal (dnd-handle-multiple-urls (selected-window)
|
||
(copy-sequence
|
||
dnd-tests-list-4)
|
||
'copy)
|
||
'private))
|
||
(should (equal (buffer-string) (nth 4 dnd-tests-list-4))))
|
||
;; Check that a handler enumerated twice in the handler list
|
||
;; receives URIs assigned to it only once.
|
||
(let* ((received-p nil)
|
||
(lambda (lambda (uri _action)
|
||
(should (equal uri "scheme1://test"))
|
||
(should (null received-p))
|
||
(setq received-p 'copy))))
|
||
(setq dnd-protocol-alist (list (cons "scheme1://" lambda)
|
||
(cons "scheme1://" lambda)))
|
||
(should (equal (dnd-handle-multiple-urls (selected-window)
|
||
(list "scheme1://test")
|
||
'copy)
|
||
'copy)))))
|
||
|
||
(ert-deftest dnd-tests-default-file-name-handlers ()
|
||
(let* ((local-files-opened nil)
|
||
(remote-files-opened nil)
|
||
(function-1 (lambda (file _uri)
|
||
(push file local-files-opened)
|
||
'copy))
|
||
(function-2 (lambda (file _uri)
|
||
(push file remote-files-opened)
|
||
'copy)))
|
||
(unwind-protect
|
||
(progn
|
||
(advice-add #'dnd-open-local-file :override
|
||
function-1)
|
||
(advice-add #'dnd-open-file :override
|
||
function-2)
|
||
;; Guarantee that file names are properly categorized as either
|
||
;; local or remote by the default dnd-protocol-alist.
|
||
(dnd-handle-multiple-urls
|
||
(selected-window)
|
||
(list
|
||
;; These are run-of-the-mill local file URIs.
|
||
"file:///usr/include/sys/acct.h"
|
||
"file:///usr/include/sys/acctctl.h"
|
||
;; These URIs incorporate a host; they should match
|
||
;; function-2 but never function-1.
|
||
"file://remotehost/usr/src/emacs/configure.ac"
|
||
"file://remotehost/usr/src/emacs/configure"
|
||
;; These URIs are generated by drag-and-drop event
|
||
;; handlers from local file names alone; they are not
|
||
;; echt URIs in and of themselves, but a product of our
|
||
;; drag and drop code.
|
||
"file:/etc/vfstab"
|
||
"file:/etc/dfs/sharetab"
|
||
;; These URIs are generated under MS-Windows.
|
||
"file:c:/path/to/file/name"
|
||
"file:d:/path/to/file/name")
|
||
'copy)
|
||
(should (equal (sort local-files-opened #'string<)
|
||
'("file:///usr/include/sys/acct.h"
|
||
"file:///usr/include/sys/acctctl.h"
|
||
"file:/etc/dfs/sharetab"
|
||
"file:/etc/vfstab"
|
||
"file:c:/path/to/file/name"
|
||
"file:d:/path/to/file/name")))
|
||
(should (equal (sort remote-files-opened #'string<)
|
||
'("file://remotehost/usr/src/emacs/configure"
|
||
"file://remotehost/usr/src/emacs/configure.ac"))))
|
||
(advice-remove #'dnd-open-local-file function-2))))
|
||
|
||
(provide 'dnd-tests)
|
||
;;; dnd-tests.el ends here
|