1018 lines
34 KiB
EmacsLisp
1018 lines
34 KiB
EmacsLisp
;;; tramp-archive-tests.el --- Tests of file archive access -*- lexical-binding:t -*-
|
|
|
|
;; Copyright (C) 2017-2024 Free Software Foundation, Inc.
|
|
|
|
;; Author: Michael Albinus <michael.albinus@gmx.de>
|
|
|
|
;; 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:
|
|
|
|
;; A testsuite for testing file archives.
|
|
|
|
;;; Code:
|
|
|
|
;; The `tramp-archive-testnn-*' tests correspond to the respective
|
|
;; tests in tramp-tests.el.
|
|
|
|
(require 'ert)
|
|
(require 'ert-x)
|
|
(require 'tramp-archive)
|
|
(defvar tramp-persistency-file-name)
|
|
|
|
(defvar tramp-archive-test-file-archive (ert-resource-file "foo.tar.gz")
|
|
"The test file archive.")
|
|
|
|
(defun tramp-archive-test-file-archive-hexlified ()
|
|
"Return hexlified `tramp-archive-test-file-archive'.
|
|
Do not hexlify \"/\". This hexlified string is used in `file:///' URLs."
|
|
(let* ((url-unreserved-chars (cons ?/ url-unreserved-chars)))
|
|
(url-hexify-string tramp-archive-test-file-archive)))
|
|
|
|
(defvar tramp-archive-test-archive
|
|
(file-name-as-directory tramp-archive-test-file-archive)
|
|
"The test archive.")
|
|
|
|
(defconst tramp-archive-test-directory
|
|
(file-truename (ert-resource-file "foo.iso"))
|
|
"A directory file name, which looks like an archive.")
|
|
|
|
(setq password-cache-expiry nil
|
|
tramp-cache-read-persistent-data t ;; For auth-sources.
|
|
tramp-persistency-file-name nil
|
|
tramp-verbose 0)
|
|
|
|
(defun tramp-archive--test-make-temp-name ()
|
|
"Return a temporary file name for test.
|
|
The temporary file is not created."
|
|
(expand-file-name
|
|
(make-temp-name "tramp-archive-test") temporary-file-directory))
|
|
|
|
(defun tramp-archive--test-delete (tmpfile)
|
|
"Delete temporary file or directory TMPFILE.
|
|
This needs special support, because archive file names, which are
|
|
the origin of the temporary TMPFILE, have no write permissions."
|
|
(unless (file-writable-p (file-name-directory tmpfile))
|
|
(set-file-modes
|
|
(file-name-directory tmpfile)
|
|
(logior (file-modes (file-name-directory tmpfile)) #o0700)))
|
|
(set-file-modes tmpfile #o0700)
|
|
(if (file-regular-p tmpfile)
|
|
(delete-file tmpfile)
|
|
(mapc
|
|
#'tramp-archive--test-delete
|
|
(directory-files tmpfile 'full directory-files-no-dot-files-regexp))
|
|
(delete-directory tmpfile)))
|
|
|
|
(ert-deftest tramp-archive-test00-availability ()
|
|
"Test availability of archive file name functions."
|
|
:expected-result (if tramp-archive-enabled :passed :failed)
|
|
(should
|
|
(and
|
|
tramp-archive-enabled
|
|
(file-exists-p tramp-archive-test-file-archive)
|
|
(tramp-archive-file-name-p tramp-archive-test-archive))))
|
|
|
|
(ert-deftest tramp-archive-test01-file-name-syntax ()
|
|
"Check archive file name syntax."
|
|
(should-not (tramp-archive-file-name-p tramp-archive-test-file-archive))
|
|
(should (tramp-archive-file-name-p tramp-archive-test-archive))
|
|
(should
|
|
(string-equal
|
|
(tramp-archive-file-name-archive tramp-archive-test-archive)
|
|
tramp-archive-test-file-archive))
|
|
(should
|
|
(string-equal
|
|
(tramp-archive-file-name-localname tramp-archive-test-archive) "/"))
|
|
(should (tramp-archive-file-name-p (concat tramp-archive-test-archive "foo")))
|
|
(should
|
|
(string-equal
|
|
(tramp-archive-file-name-localname
|
|
(concat tramp-archive-test-archive "foo"))
|
|
"/foo"))
|
|
(should
|
|
(tramp-archive-file-name-p (concat tramp-archive-test-archive "foo/bar")))
|
|
(should
|
|
(string-equal
|
|
(tramp-archive-file-name-localname
|
|
(concat tramp-archive-test-archive "foo/bar"))
|
|
"/foo/bar"))
|
|
;; A file archive inside a file archive.
|
|
(should
|
|
(tramp-archive-file-name-p (concat tramp-archive-test-archive "baz.tar")))
|
|
(should
|
|
(string-equal
|
|
(tramp-archive-file-name-archive
|
|
(concat tramp-archive-test-archive "baz.tar"))
|
|
tramp-archive-test-file-archive))
|
|
(should
|
|
(string-equal
|
|
(tramp-archive-file-name-localname
|
|
(concat tramp-archive-test-archive "baz.tar"))
|
|
"/baz.tar"))
|
|
(should
|
|
(tramp-archive-file-name-p (concat tramp-archive-test-archive "baz.tar/")))
|
|
(should
|
|
(string-equal
|
|
(tramp-archive-file-name-archive
|
|
(concat tramp-archive-test-archive "baz.tar/"))
|
|
(concat tramp-archive-test-archive "baz.tar")))
|
|
(should
|
|
(string-equal
|
|
(tramp-archive-file-name-localname
|
|
(concat tramp-archive-test-archive "baz.tar/"))
|
|
"/")))
|
|
|
|
(ert-deftest tramp-archive-test02-file-name-dissect ()
|
|
"Check archive file name components."
|
|
(skip-unless tramp-archive-enabled)
|
|
|
|
;; Suppress method name check.
|
|
(let ((non-essential t))
|
|
(with-parsed-tramp-archive-file-name tramp-archive-test-archive nil
|
|
(should (string-equal method tramp-archive-method))
|
|
(should-not user)
|
|
(should-not domain)
|
|
(should
|
|
(string-equal
|
|
host
|
|
(file-remote-p
|
|
(tramp-archive-gvfs-file-name tramp-archive-test-archive) 'host)))
|
|
(should
|
|
(string-equal
|
|
host
|
|
(url-hexify-string
|
|
(concat "file://" (tramp-archive-test-file-archive-hexlified)))))
|
|
(should-not port)
|
|
(should (string-equal localname "/"))
|
|
(should (string-equal archive tramp-archive-test-file-archive)))
|
|
|
|
;; Localname.
|
|
(with-parsed-tramp-archive-file-name
|
|
(concat tramp-archive-test-archive "foo") nil
|
|
(should (string-equal method tramp-archive-method))
|
|
(should-not user)
|
|
(should-not domain)
|
|
(should
|
|
(string-equal
|
|
host
|
|
(file-remote-p
|
|
(tramp-archive-gvfs-file-name tramp-archive-test-archive) 'host)))
|
|
(should
|
|
(string-equal
|
|
host
|
|
(url-hexify-string
|
|
(concat "file://" (tramp-archive-test-file-archive-hexlified)))))
|
|
(should-not port)
|
|
(should (string-equal localname "/foo"))
|
|
(should (string-equal archive tramp-archive-test-file-archive)))
|
|
|
|
;; File archive in file archive.
|
|
(let* ((tramp-archive-test-file-archive
|
|
(concat tramp-archive-test-archive "baz.tar"))
|
|
(tramp-archive-test-archive
|
|
(file-name-as-directory tramp-archive-test-file-archive))
|
|
(tramp-methods (cons `(,tramp-archive-method) tramp-methods))
|
|
(tramp-gvfs-methods tramp-archive-all-gvfs-methods))
|
|
(unwind-protect
|
|
(with-parsed-tramp-archive-file-name
|
|
(expand-file-name "bar" tramp-archive-test-archive) nil
|
|
(should (string-equal method tramp-archive-method))
|
|
(should-not user)
|
|
(should-not domain)
|
|
(should
|
|
(string-equal
|
|
host
|
|
(file-remote-p
|
|
(tramp-archive-gvfs-file-name tramp-archive-test-archive)
|
|
'host)))
|
|
;; We reimplement the logic of tramp-archive.el here.
|
|
;; Don't know, whether it is worth the test.
|
|
(should
|
|
(string-equal
|
|
host
|
|
(url-hexify-string
|
|
(concat
|
|
(tramp-gvfs-url-file-name
|
|
(tramp-make-tramp-file-name
|
|
(make-tramp-file-name
|
|
:method tramp-archive-method
|
|
:host
|
|
(url-hexify-string
|
|
(concat
|
|
"file://"
|
|
;; `directory-file-name' does not leave file
|
|
;; archive boundaries. So we must cut the
|
|
;; trailing slash ourselves.
|
|
(substring
|
|
(file-name-directory
|
|
(tramp-archive-test-file-archive-hexlified))
|
|
0 -1)))
|
|
:localname "/")))
|
|
(file-name-nondirectory tramp-archive-test-file-archive)))))
|
|
(should-not port)
|
|
(should (string-equal localname "/bar"))
|
|
(should (string-equal archive tramp-archive-test-file-archive)))
|
|
|
|
;; Cleanup.
|
|
(tramp-archive-cleanup-hash)))))
|
|
|
|
(ert-deftest tramp-archive-test05-expand-file-name ()
|
|
"Check `expand-file-name'."
|
|
(should
|
|
(string-equal
|
|
(expand-file-name (concat tramp-archive-test-archive "path/./file"))
|
|
(concat tramp-archive-test-archive "path/file")))
|
|
(should
|
|
(string-equal
|
|
(expand-file-name (concat tramp-archive-test-archive "path/../file"))
|
|
(concat tramp-archive-test-archive "file")))
|
|
;; `expand-file-name' does not care "~/" in archive file names.
|
|
(should
|
|
(string-equal
|
|
(expand-file-name (concat tramp-archive-test-archive "~/file"))
|
|
(concat tramp-archive-test-archive "~/file")))
|
|
;; `expand-file-name' does not care file archive boundaries.
|
|
(should
|
|
(string-equal
|
|
(expand-file-name (concat tramp-archive-test-archive "./file"))
|
|
(concat tramp-archive-test-archive "file")))
|
|
(should
|
|
(string-equal
|
|
(expand-file-name (concat tramp-archive-test-archive "../file"))
|
|
(concat (ert-resource-directory) "file"))))
|
|
|
|
;; This test is inspired by Bug#30293.
|
|
(ert-deftest tramp-archive-test05-expand-file-name-non-archive-directory ()
|
|
"Check existing directories with archive file name syntax.
|
|
They shall still be supported"
|
|
(should (file-directory-p tramp-archive-test-directory))
|
|
;; `tramp-archive-file-name-p' tests only for file name syntax. It
|
|
;; doesn't test, whether it is really a file archive.
|
|
(should
|
|
(tramp-archive-file-name-p
|
|
(file-name-as-directory tramp-archive-test-directory)))
|
|
(should
|
|
(file-directory-p (file-name-as-directory tramp-archive-test-directory)))
|
|
(should
|
|
(file-exists-p (expand-file-name "foo" tramp-archive-test-directory))))
|
|
|
|
(ert-deftest tramp-archive-test06-directory-file-name ()
|
|
"Check `directory-file-name'.
|
|
This checks also `file-name-as-directory', `file-name-directory',
|
|
`file-name-nondirectory' and `unhandled-file-name-directory'."
|
|
(skip-unless tramp-archive-enabled)
|
|
|
|
(should
|
|
(string-equal
|
|
(directory-file-name (concat tramp-archive-test-archive "path/to/file"))
|
|
(concat tramp-archive-test-archive "path/to/file")))
|
|
(should
|
|
(string-equal
|
|
(directory-file-name (concat tramp-archive-test-archive "path/to/file/"))
|
|
(concat tramp-archive-test-archive "path/to/file")))
|
|
;; `directory-file-name' does not leave file archive boundaries.
|
|
(should
|
|
(string-equal
|
|
(directory-file-name tramp-archive-test-archive) tramp-archive-test-archive))
|
|
|
|
(should
|
|
(string-equal
|
|
(file-name-as-directory (concat tramp-archive-test-archive "path/to/file"))
|
|
(concat tramp-archive-test-archive "path/to/file/")))
|
|
(should
|
|
(string-equal
|
|
(file-name-as-directory (concat tramp-archive-test-archive "path/to/file/"))
|
|
(concat tramp-archive-test-archive "path/to/file/")))
|
|
(should
|
|
(string-equal
|
|
(file-name-as-directory tramp-archive-test-archive)
|
|
tramp-archive-test-archive))
|
|
(should
|
|
(string-equal
|
|
(file-name-as-directory tramp-archive-test-file-archive)
|
|
tramp-archive-test-archive))
|
|
|
|
(should
|
|
(string-equal
|
|
(file-name-directory (concat tramp-archive-test-archive "path/to/file"))
|
|
(concat tramp-archive-test-archive "path/to/")))
|
|
(should
|
|
(string-equal
|
|
(file-name-directory (concat tramp-archive-test-archive "path/to/file/"))
|
|
(concat tramp-archive-test-archive "path/to/file/")))
|
|
(should
|
|
(string-equal
|
|
(file-name-directory tramp-archive-test-archive) tramp-archive-test-archive))
|
|
|
|
(should
|
|
(string-equal
|
|
(file-name-nondirectory (concat tramp-archive-test-archive "path/to/file"))
|
|
"file"))
|
|
(should
|
|
(string-equal
|
|
(file-name-nondirectory (concat tramp-archive-test-archive "path/to/file/"))
|
|
""))
|
|
(should (string-equal (file-name-nondirectory tramp-archive-test-archive) ""))
|
|
|
|
(should-not
|
|
(unhandled-file-name-directory
|
|
(concat tramp-archive-test-archive "path/to/file"))))
|
|
|
|
(ert-deftest tramp-archive-test07-file-exists-p ()
|
|
"Check `file-exist-p', `write-region' and `delete-file'."
|
|
:tags '(:expensive-test)
|
|
(skip-unless tramp-archive-enabled)
|
|
|
|
(unwind-protect
|
|
(let ((default-directory tramp-archive-test-archive))
|
|
(should (file-exists-p tramp-archive-test-file-archive))
|
|
(should (file-exists-p tramp-archive-test-archive))
|
|
(should (file-exists-p "foo.txt"))
|
|
(should (file-exists-p "foo.lnk"))
|
|
(should (file-exists-p "bar"))
|
|
(should (file-exists-p "bar/bar"))
|
|
(should-error
|
|
(write-region "foo" nil "baz")
|
|
:type 'file-error)
|
|
(should-error
|
|
(delete-file "baz")
|
|
:type 'file-error))
|
|
|
|
;; Cleanup.
|
|
(tramp-archive-cleanup-hash)))
|
|
|
|
(ert-deftest tramp-archive-test08-file-local-copy ()
|
|
"Check `file-local-copy'."
|
|
:tags '(:expensive-test)
|
|
(skip-unless tramp-archive-enabled)
|
|
|
|
(let (tmp-name)
|
|
(unwind-protect
|
|
(progn
|
|
(should
|
|
(setq tmp-name
|
|
(file-local-copy
|
|
(expand-file-name "bar/bar" tramp-archive-test-archive))))
|
|
(with-temp-buffer
|
|
(insert-file-contents tmp-name)
|
|
(should (string-equal (buffer-string) "bar\n")))
|
|
;; Error case.
|
|
(tramp-archive--test-delete tmp-name)
|
|
(should-error
|
|
(setq tmp-name
|
|
(file-local-copy
|
|
(expand-file-name "what" tramp-archive-test-archive)))
|
|
:type 'file-missing))
|
|
|
|
;; Cleanup.
|
|
(ignore-errors (tramp-archive--test-delete tmp-name))
|
|
(tramp-archive-cleanup-hash))))
|
|
|
|
(ert-deftest tramp-archive-test09-insert-file-contents ()
|
|
"Check `insert-file-contents'."
|
|
:tags '(:expensive-test)
|
|
(skip-unless tramp-archive-enabled)
|
|
|
|
(let ((tmp-name (expand-file-name "bar/bar" tramp-archive-test-archive)))
|
|
(unwind-protect
|
|
(with-temp-buffer
|
|
(insert-file-contents tmp-name)
|
|
(should (string-equal (buffer-string) "bar\n"))
|
|
(insert-file-contents tmp-name)
|
|
(should (string-equal (buffer-string) "bar\nbar\n"))
|
|
;; Insert partly.
|
|
(insert-file-contents tmp-name nil 1 3)
|
|
(should (string-equal (buffer-string) "arbar\nbar\n"))
|
|
;; Replace.
|
|
(insert-file-contents tmp-name nil nil nil 'replace)
|
|
(should (string-equal (buffer-string) "bar\n"))
|
|
;; Error case.
|
|
(should-error
|
|
(insert-file-contents
|
|
(expand-file-name "what" tramp-archive-test-archive))
|
|
:type 'file-missing))
|
|
|
|
;; Cleanup.
|
|
(tramp-archive-cleanup-hash))))
|
|
|
|
(ert-deftest tramp-archive-test11-copy-file ()
|
|
"Check `copy-file'."
|
|
:tags '(:expensive-test)
|
|
(skip-unless tramp-archive-enabled)
|
|
|
|
;; Copy simple file.
|
|
(let ((tmp-name1 (expand-file-name "bar/bar" tramp-archive-test-archive))
|
|
(tmp-name2 (tramp-archive--test-make-temp-name)))
|
|
(unwind-protect
|
|
(progn
|
|
(copy-file tmp-name1 tmp-name2)
|
|
(should (file-exists-p tmp-name2))
|
|
(with-temp-buffer
|
|
(insert-file-contents tmp-name2)
|
|
(should (string-equal (buffer-string) "bar\n")))
|
|
(should-error
|
|
(copy-file tmp-name1 tmp-name2)
|
|
:type 'file-already-exists)
|
|
(copy-file tmp-name1 tmp-name2 'ok)
|
|
;; The file archive is not writable.
|
|
(should-error
|
|
(copy-file tmp-name2 tmp-name1 'ok)
|
|
:type 'file-error))
|
|
|
|
;; Cleanup.
|
|
(ignore-errors (tramp-archive--test-delete tmp-name2))
|
|
(tramp-archive-cleanup-hash)))
|
|
|
|
;; Copy directory to existing directory.
|
|
(let ((tmp-name1 (expand-file-name "bar" tramp-archive-test-archive))
|
|
(tmp-name2 (tramp-archive--test-make-temp-name)))
|
|
(unwind-protect
|
|
(progn
|
|
(make-directory tmp-name2)
|
|
(should (file-directory-p tmp-name2))
|
|
;; Directory `tmp-name2' exists already, so we must use
|
|
;; `file-name-as-directory'.
|
|
(copy-file tmp-name1 (file-name-as-directory tmp-name2))
|
|
(should
|
|
(file-exists-p
|
|
(expand-file-name
|
|
(concat (file-name-nondirectory tmp-name1) "/bar") tmp-name2))))
|
|
|
|
;; Cleanup.
|
|
(ignore-errors (tramp-archive--test-delete tmp-name2))
|
|
(tramp-archive-cleanup-hash)))
|
|
|
|
;; Copy directory/file to non-existing directory.
|
|
(let ((tmp-name1 (expand-file-name "bar" tramp-archive-test-archive))
|
|
(tmp-name2 (tramp-archive--test-make-temp-name)))
|
|
(unwind-protect
|
|
(progn
|
|
(make-directory tmp-name2)
|
|
(should (file-directory-p tmp-name2))
|
|
(copy-file
|
|
tmp-name1
|
|
(expand-file-name (file-name-nondirectory tmp-name1) tmp-name2))
|
|
(should
|
|
(file-exists-p
|
|
(expand-file-name
|
|
(concat (file-name-nondirectory tmp-name1) "/bar") tmp-name2))))
|
|
|
|
;; Cleanup.
|
|
(ignore-errors (tramp-archive--test-delete tmp-name2))
|
|
(tramp-archive-cleanup-hash))))
|
|
|
|
(ert-deftest tramp-archive-test15-copy-directory ()
|
|
"Check `copy-directory'."
|
|
:tags '(:expensive-test)
|
|
(skip-unless tramp-archive-enabled)
|
|
|
|
(let* ((tmp-name1 (expand-file-name "bar" tramp-archive-test-archive))
|
|
(tmp-name2 (tramp-archive--test-make-temp-name))
|
|
(tmp-name3 (expand-file-name
|
|
(file-name-nondirectory tmp-name1) tmp-name2))
|
|
(tmp-name4 (expand-file-name "bar" tmp-name2))
|
|
(tmp-name5 (expand-file-name "bar" tmp-name3)))
|
|
|
|
;; Copy complete directory.
|
|
(unwind-protect
|
|
(progn
|
|
;; Copy empty directory.
|
|
(copy-directory tmp-name1 tmp-name2)
|
|
(should (file-directory-p tmp-name2))
|
|
(should (file-exists-p tmp-name4))
|
|
;; Target directory does exist already.
|
|
(should-error
|
|
(copy-directory tmp-name1 tmp-name2)
|
|
:type 'file-error)
|
|
(tramp-archive--test-delete tmp-name4)
|
|
(copy-directory tmp-name1 (file-name-as-directory tmp-name2))
|
|
(should (file-directory-p tmp-name3))
|
|
(should (file-exists-p tmp-name5)))
|
|
|
|
;; Cleanup.
|
|
(ignore-errors (tramp-archive--test-delete tmp-name2))
|
|
(tramp-archive-cleanup-hash))
|
|
|
|
;; Copy directory contents.
|
|
(unwind-protect
|
|
(progn
|
|
;; Copy empty directory.
|
|
(copy-directory tmp-name1 tmp-name2 nil 'parents 'contents)
|
|
(should (file-directory-p tmp-name2))
|
|
(should (file-exists-p tmp-name4))
|
|
;; Target directory does exist already.
|
|
(tramp-archive--test-delete tmp-name4)
|
|
(copy-directory
|
|
tmp-name1 (file-name-as-directory tmp-name2)
|
|
nil 'parents 'contents)
|
|
(should (file-directory-p tmp-name2))
|
|
(should (file-exists-p tmp-name4))
|
|
(should-not (file-directory-p tmp-name3))
|
|
(should-not (file-exists-p tmp-name5)))
|
|
|
|
;; Cleanup.
|
|
(ignore-errors (tramp-archive--test-delete tmp-name2))
|
|
(tramp-archive-cleanup-hash))))
|
|
|
|
(ert-deftest tramp-archive-test16-directory-files ()
|
|
"Check `directory-files'."
|
|
:tags '(:expensive-test)
|
|
(skip-unless tramp-archive-enabled)
|
|
|
|
(let ((tmp-name tramp-archive-test-archive)
|
|
(files '("." ".." "bar" "baz.tar" "foo.hrd" "foo.lnk" "foo.txt")))
|
|
(unwind-protect
|
|
(progn
|
|
(should (file-directory-p tmp-name))
|
|
(should (equal (directory-files tmp-name) files))
|
|
(should (equal (directory-files tmp-name 'full)
|
|
(mapcar (lambda (x) (concat tmp-name x)) files)))
|
|
(should (equal (directory-files
|
|
tmp-name nil directory-files-no-dot-files-regexp)
|
|
(remove "." (remove ".." files))))
|
|
(should (equal (directory-files
|
|
tmp-name 'full directory-files-no-dot-files-regexp)
|
|
(mapcar (lambda (x) (concat tmp-name x))
|
|
(remove "." (remove ".." files))))))
|
|
|
|
;; Cleanup.
|
|
(tramp-archive-cleanup-hash))))
|
|
|
|
(ert-deftest tramp-archive-test17-insert-directory ()
|
|
"Check `insert-directory'."
|
|
:tags '(:expensive-test)
|
|
(skip-unless tramp-archive-enabled)
|
|
|
|
(let (;; We test for the summary line. Keyword "total" could be localized.
|
|
(process-environment
|
|
(append '("LANG=C" "LANGUAGE=C" "LC_ALL=C") process-environment)))
|
|
(unwind-protect
|
|
(progn
|
|
(with-temp-buffer
|
|
(insert-directory tramp-archive-test-archive nil)
|
|
(goto-char (point-min))
|
|
(should (looking-at-p (rx (literal tramp-archive-test-archive)))))
|
|
(with-temp-buffer
|
|
(insert-directory tramp-archive-test-archive "-al")
|
|
(goto-char (point-min))
|
|
(should
|
|
(looking-at-p
|
|
(rx bol (+ nonl) blank (literal tramp-archive-test-archive) eol))))
|
|
(with-temp-buffer
|
|
(insert-directory
|
|
(file-name-as-directory tramp-archive-test-archive)
|
|
"-al" nil 'full-directory-p)
|
|
(goto-char (point-min))
|
|
(should
|
|
(looking-at-p
|
|
(rx-to-string
|
|
`(:
|
|
;; There might be a summary line.
|
|
(? "total" (+ nonl) (+ digit) (? blank)
|
|
(? (any "EGKMPTYZk")) (? "i") (? "B") "\n")
|
|
;; We don't know in which order the files appear.
|
|
(= ,(length (directory-files tramp-archive-test-archive))
|
|
(+ nonl) blank
|
|
(regexp
|
|
,(regexp-opt (directory-files tramp-archive-test-archive)))
|
|
(? " ->" (+ nonl)) "\n"))))))
|
|
;; Check error case.
|
|
(with-temp-buffer
|
|
(should-error
|
|
(insert-directory
|
|
(expand-file-name "baz" tramp-archive-test-archive) nil)
|
|
:type 'file-missing)))
|
|
|
|
;; Cleanup.
|
|
(tramp-archive-cleanup-hash))))
|
|
|
|
(ert-deftest tramp-archive-test18-file-attributes ()
|
|
"Check `file-attributes'.
|
|
This tests also `access-file', `file-readable-p' and `file-regular-p'."
|
|
:tags '(:expensive-test)
|
|
(skip-unless tramp-archive-enabled)
|
|
|
|
(let ((tmp-name1 (expand-file-name "foo.txt" tramp-archive-test-archive))
|
|
(tmp-name2 (expand-file-name "foo.lnk" tramp-archive-test-archive))
|
|
(tmp-name3 (expand-file-name "bar" tramp-archive-test-archive))
|
|
(tmp-name4 (expand-file-name "baz" tramp-archive-test-archive))
|
|
attr)
|
|
(unwind-protect
|
|
(progn
|
|
(should (file-exists-p tmp-name1))
|
|
(should (file-readable-p tmp-name1))
|
|
(should (file-regular-p tmp-name1))
|
|
(should-not (access-file tmp-name1 "error"))
|
|
|
|
;; We do not test inodes and device numbers.
|
|
(setq attr (file-attributes tmp-name1))
|
|
(should (consp attr))
|
|
(should (null (car attr)))
|
|
(should (numberp (nth 1 attr))) ;; Link.
|
|
(should (numberp (nth 2 attr))) ;; Uid.
|
|
(should (numberp (nth 3 attr))) ;; Gid.
|
|
;; Last access time.
|
|
(should (stringp (current-time-string (nth 4 attr))))
|
|
;; Last modification time.
|
|
(should (stringp (current-time-string (nth 5 attr))))
|
|
;; Last status change time.
|
|
(should (stringp (current-time-string (nth 6 attr))))
|
|
(should (numberp (nth 7 attr))) ;; Size.
|
|
(should (stringp (nth 8 attr))) ;; Modes.
|
|
|
|
(setq attr (file-attributes tmp-name1 'string))
|
|
(should (stringp (nth 2 attr))) ;; Uid.
|
|
(should (stringp (nth 3 attr))) ;; Gid.
|
|
|
|
;; Symlink.
|
|
(should (file-exists-p tmp-name2))
|
|
(should (file-symlink-p tmp-name2))
|
|
(should (file-regular-p tmp-name2))
|
|
(setq attr (file-attributes tmp-name2))
|
|
(should (string-equal (car attr) (file-name-nondirectory tmp-name1)))
|
|
|
|
;; Directory.
|
|
(should (file-exists-p tmp-name3))
|
|
(should (file-readable-p tmp-name3))
|
|
(should-not (file-regular-p tmp-name3))
|
|
(setq attr (file-attributes tmp-name3))
|
|
(should (eq (car attr) t))
|
|
(should-not (access-file tmp-name3 "error"))
|
|
|
|
;; Check error case.
|
|
(should-error
|
|
(access-file tmp-name4 "error")
|
|
:type 'file-missing))
|
|
|
|
;; Cleanup.
|
|
(tramp-archive-cleanup-hash))))
|
|
|
|
(ert-deftest tramp-archive-test19-directory-files-and-attributes ()
|
|
"Check `directory-files-and-attributes'."
|
|
:tags '(:expensive-test)
|
|
(skip-unless tramp-archive-enabled)
|
|
|
|
(let ((tmp-name (expand-file-name "bar" tramp-archive-test-archive))
|
|
attr)
|
|
(unwind-protect
|
|
(progn
|
|
(should (file-directory-p tmp-name))
|
|
(setq attr (directory-files-and-attributes tmp-name))
|
|
(should (consp attr))
|
|
(dolist (elt attr)
|
|
(should
|
|
(equal (file-attributes (expand-file-name (car elt) tmp-name))
|
|
(cdr elt))))
|
|
(setq attr (directory-files-and-attributes tmp-name 'full))
|
|
(dolist (elt attr)
|
|
(should (equal (file-attributes (car elt)) (cdr elt))))
|
|
(setq attr (directory-files-and-attributes tmp-name nil (rx bos "b")))
|
|
(should (equal (mapcar #'car attr) '("bar"))))
|
|
|
|
;; Cleanup.
|
|
(tramp-archive-cleanup-hash))))
|
|
|
|
(ert-deftest tramp-archive-test20-file-modes ()
|
|
"Check `file-modes'.
|
|
This tests also `file-executable-p', `file-writable-p' and `set-file-modes'."
|
|
:tags '(:expensive-test)
|
|
(skip-unless tramp-archive-enabled)
|
|
|
|
(let ((tmp-name1 (expand-file-name "foo.txt" tramp-archive-test-archive))
|
|
(tmp-name2 (expand-file-name "bar" tramp-archive-test-archive)))
|
|
(unwind-protect
|
|
(progn
|
|
(should (file-exists-p tmp-name1))
|
|
;; `set-file-modes' is not implemented.
|
|
(should-error
|
|
(set-file-modes tmp-name1 #o777)
|
|
:type 'file-error)
|
|
(should (= (file-modes tmp-name1) #o400))
|
|
(should-not (file-executable-p tmp-name1))
|
|
(should-not (file-writable-p tmp-name1))
|
|
|
|
(should (file-exists-p tmp-name2))
|
|
;; `set-file-modes' is not implemented.
|
|
(should-error
|
|
(set-file-modes tmp-name2 #o777)
|
|
:type 'file-error)
|
|
(should (= (file-modes tmp-name2) #o500))
|
|
(should (file-executable-p tmp-name2))
|
|
(should-not (file-writable-p tmp-name2)))
|
|
|
|
;; Cleanup.
|
|
(tramp-archive-cleanup-hash))))
|
|
|
|
(ert-deftest tramp-archive-test21-file-links ()
|
|
"Check `file-symlink-p' and `file-truename'"
|
|
:tags '(:expensive-test)
|
|
(skip-unless tramp-archive-enabled)
|
|
|
|
;; We must use `file-truename' for the file archive, because it
|
|
;; could be located on a symlinked directory. This would let the
|
|
;; test fail.
|
|
(let* ((tramp-archive-test-archive (file-truename tramp-archive-test-archive))
|
|
(tmp-name1 (expand-file-name "foo.txt" tramp-archive-test-archive))
|
|
(tmp-name2 (expand-file-name "foo.lnk" tramp-archive-test-archive)))
|
|
|
|
(unwind-protect
|
|
(progn
|
|
(should (file-exists-p tmp-name1))
|
|
(should (file-regular-p tmp-name1))
|
|
(should (string-equal tmp-name1 (file-truename tmp-name1)))
|
|
;; `make-symbolic-link' is not implemented.
|
|
(should-error
|
|
(make-symbolic-link tmp-name1 tmp-name2)
|
|
:type 'file-error)
|
|
(should (file-symlink-p tmp-name2))
|
|
(should (file-regular-p tmp-name2))
|
|
(should
|
|
(string-equal
|
|
;; This is "/foo.txt".
|
|
(with-parsed-tramp-archive-file-name tmp-name1 nil localname)
|
|
;; `file-symlink-p' returns "foo.txt". Wer must expand, therefore.
|
|
(with-parsed-tramp-archive-file-name
|
|
(expand-file-name
|
|
(file-symlink-p tmp-name2) tramp-archive-test-archive)
|
|
nil
|
|
localname)))
|
|
(should-not (string-equal tmp-name2 (file-truename tmp-name2)))
|
|
(should
|
|
(string-equal (file-truename tmp-name1) (file-truename tmp-name2)))
|
|
(should (file-equal-p tmp-name1 tmp-name2)))
|
|
|
|
;; Cleanup.
|
|
(tramp-archive-cleanup-hash))))
|
|
|
|
(ert-deftest tramp-archive-test26-file-name-completion ()
|
|
"Check `file-name-completion' and `file-name-all-completions'."
|
|
:tags '(:expensive-test)
|
|
(skip-unless tramp-archive-enabled)
|
|
|
|
(let ((tmp-name tramp-archive-test-archive))
|
|
(unwind-protect
|
|
(progn
|
|
;; Local files.
|
|
(should (equal (file-name-completion "fo" tmp-name) "foo."))
|
|
(should (equal (file-name-completion "foo.txt" tmp-name) t))
|
|
(should (equal (file-name-completion "b" tmp-name) "ba"))
|
|
(should-not (file-name-completion "a" tmp-name))
|
|
(should
|
|
(equal
|
|
(file-name-completion "b" tmp-name #'file-directory-p) "bar/"))
|
|
(should
|
|
(equal
|
|
(sort (file-name-all-completions "fo" tmp-name) #'string-lessp)
|
|
'("foo.hrd" "foo.lnk" "foo.txt")))
|
|
(should
|
|
(equal
|
|
(sort (file-name-all-completions "b" tmp-name) #'string-lessp)
|
|
'("bar/" "baz.tar")))
|
|
(should-not (file-name-all-completions "a" tmp-name))
|
|
;; `completion-regexp-list' restricts the completion to
|
|
;; files which match all expressions in this list.
|
|
(let ((completion-regexp-list
|
|
`(,directory-files-no-dot-files-regexp "b")))
|
|
(should
|
|
(equal (file-name-completion "" tmp-name) "ba"))
|
|
(should
|
|
(equal
|
|
(sort (file-name-all-completions "" tmp-name) #'string-lessp)
|
|
'("bar/" "baz.tar")))))
|
|
|
|
;; Cleanup.
|
|
(tramp-archive-cleanup-hash))))
|
|
|
|
(ert-deftest tramp-archive-test40-make-nearby-temp-file ()
|
|
"Check `make-nearby-temp-file' and `temporary-file-directory'."
|
|
(skip-unless tramp-archive-enabled)
|
|
|
|
(let ((default-directory tramp-archive-test-archive)
|
|
tmp-file)
|
|
;; The file archive shall know a temporary file directory. It is
|
|
;; not in the archive itself.
|
|
(should (stringp (temporary-file-directory)))
|
|
(should-not (tramp-archive-file-name-p (temporary-file-directory)))
|
|
|
|
;; A temporary file or directory shall not be located in the
|
|
;; archive itself.
|
|
(setq tmp-file (make-nearby-temp-file "tramp-archive-test"))
|
|
(should (file-exists-p tmp-file))
|
|
(should (file-regular-p tmp-file))
|
|
(should-not (tramp-archive-file-name-p tmp-file))
|
|
(delete-file tmp-file)
|
|
(should-not (file-exists-p tmp-file))
|
|
|
|
(setq tmp-file (make-nearby-temp-file "tramp-archive-test" 'dir))
|
|
(should (file-exists-p tmp-file))
|
|
(should (file-directory-p tmp-file))
|
|
(should-not (tramp-archive-file-name-p tmp-file))
|
|
(delete-directory tmp-file)
|
|
(should-not (file-exists-p tmp-file))))
|
|
|
|
(ert-deftest tramp-archive-test43-file-system-info ()
|
|
"Check that `file-system-info' returns proper values."
|
|
(skip-unless tramp-archive-enabled)
|
|
|
|
(let ((fsi (file-system-info tramp-archive-test-archive)))
|
|
(skip-unless fsi)
|
|
(should (and (consp fsi)
|
|
(length= fsi 3)
|
|
(numberp (nth 0 fsi))
|
|
;; FREE and AVAIL are always 0.
|
|
(zerop (nth 1 fsi))
|
|
(zerop (nth 2 fsi))))))
|
|
|
|
;; `file-user-uid' and `file-group-gid' were introduced in Emacs 30.1.
|
|
(ert-deftest tramp-archive-test44-user-group-ids ()
|
|
"Check results of user/group functions.
|
|
`file-user-uid' and `file-group-gid' should return proper values."
|
|
(skip-unless tramp-archive-enabled)
|
|
(skip-unless (and (fboundp 'file-user-uid)
|
|
(fboundp 'file-group-gid)))
|
|
|
|
;; `file-user-uid' and `file-group-gid' exist since Emacs 30.1.
|
|
;; We don't want to see compiler warnings for older Emacsen.
|
|
(let* ((default-directory tramp-archive-test-archive)
|
|
(uid (with-no-warnings (file-user-uid)))
|
|
(gid (with-no-warnings (file-group-gid))))
|
|
(should (integerp uid))
|
|
(should (integerp gid))
|
|
(let ((default-directory tramp-archive-test-file-archive))
|
|
(should (equal uid (with-no-warnings (file-user-uid))))
|
|
(should (equal gid (with-no-warnings (file-group-gid)))))))
|
|
|
|
(ert-deftest tramp-archive-test48-auto-load ()
|
|
"Check that `tramp-archive' autoloads properly."
|
|
:tags '(:expensive-test)
|
|
(skip-unless tramp-archive-enabled)
|
|
|
|
;; tramp-archive is neither loaded at Emacs startup, nor when
|
|
;; loading a file like "/mock::foo" (which loads Tramp).
|
|
(let ((code
|
|
"(progn \
|
|
(message \"tramp-archive loaded: %%s\" \
|
|
(featurep 'tramp-archive)) \
|
|
(let ((inhibit-message t)) \
|
|
(file-attributes %S \"/\")) \
|
|
(message \"tramp-archive loaded: %%s\" \
|
|
(featurep 'tramp-archive))))"))
|
|
(dolist (enabled '(t nil))
|
|
(dolist (default-directory
|
|
(append
|
|
`(,temporary-file-directory)
|
|
`(,(file-name-as-directory tramp-archive-test-directory))))
|
|
(dolist (file `("/mock::foo" ,(concat tramp-archive-test-archive "foo")))
|
|
(should
|
|
(string-match
|
|
(rx
|
|
"tramp-archive loaded: "
|
|
(literal (symbol-name
|
|
(tramp-archive-file-name-p default-directory)))
|
|
(+ ascii)
|
|
"tramp-archive loaded: "
|
|
(literal (symbol-name
|
|
(or (tramp-archive-file-name-p default-directory)
|
|
(and enabled (tramp-archive-file-name-p file))))))
|
|
(shell-command-to-string
|
|
(format
|
|
"%s -batch -Q -L %s --eval %s --eval %s"
|
|
(shell-quote-argument
|
|
(expand-file-name invocation-name invocation-directory))
|
|
(mapconcat #'shell-quote-argument load-path " -L ")
|
|
(shell-quote-argument
|
|
(format "(setq tramp-archive-enabled %s)" enabled))
|
|
(shell-quote-argument (format code file)))))))))))
|
|
|
|
(ert-deftest tramp-archive-test48-delay-load ()
|
|
"Check that `tramp-archive' is loaded lazily, only when needed."
|
|
:tags '(:expensive-test)
|
|
(skip-unless tramp-archive-enabled)
|
|
|
|
;; tramp-archive is neither loaded at Emacs startup, nor when
|
|
;; loading a file like "/foo.tar". It is loaded only when
|
|
;; `tramp-archive-enabled' is t.
|
|
(let ((default-directory (expand-file-name temporary-file-directory))
|
|
(code
|
|
"(progn \
|
|
(setq tramp-archive-enabled %s) \
|
|
(message \"tramp-archive loaded: %%s\" \
|
|
(featurep 'tramp-archive)) \
|
|
(file-attributes %S \"/\") \
|
|
(message \"tramp-archive loaded: %%s\" \
|
|
(featurep 'tramp-archive)) \
|
|
(file-attributes %S \"/\") \
|
|
(message \"tramp-archive loaded: %%s\" \
|
|
(featurep 'tramp-archive)))"))
|
|
;; tramp-archive doesn't load when `tramp-archive-enabled' is nil.
|
|
(dolist (tae '(t nil))
|
|
(should
|
|
(string-match
|
|
(rx
|
|
"tramp-archive loaded: nil" (+ ascii)
|
|
"tramp-archive loaded: nil" (+ ascii)
|
|
"tramp-archive loaded: " (literal (symbol-name tae)))
|
|
(shell-command-to-string
|
|
(format
|
|
"%s -batch -Q -L %s --eval %s"
|
|
(shell-quote-argument
|
|
(expand-file-name invocation-name invocation-directory))
|
|
(mapconcat #'shell-quote-argument load-path " -L ")
|
|
(shell-quote-argument
|
|
(format
|
|
code tae tramp-archive-test-file-archive
|
|
(concat tramp-archive-test-archive "foo"))))))))))
|
|
|
|
(ert-deftest tramp-archive-test49-without-remote-files ()
|
|
"Check that Tramp can be suppressed."
|
|
(skip-unless tramp-archive-enabled)
|
|
|
|
(should (file-exists-p tramp-archive-test-archive))
|
|
(should-not (without-remote-files (file-exists-p tramp-archive-test-archive)))
|
|
(should (file-exists-p tramp-archive-test-archive))
|
|
|
|
(inhibit-remote-files)
|
|
(should-not (file-exists-p tramp-archive-test-archive))
|
|
(tramp-register-file-name-handlers)
|
|
(setq tramp-mode t)
|
|
(should (file-exists-p tramp-archive-test-archive)))
|
|
|
|
(ert-deftest tramp-archive-test99-libarchive-tests ()
|
|
"Run tests of libarchive test files."
|
|
:tags '(:expensive-test :unstable)
|
|
(skip-unless tramp-archive-enabled)
|
|
;; We do not want to run unless chosen explicitly. This test makes
|
|
;; sense only in my local environment. Michael Albinus.
|
|
(skip-unless
|
|
(equal
|
|
(ert--stats-selector ert--current-run-stats)
|
|
(ert-test-name (ert-running-test))))
|
|
|
|
(url-handler-mode)
|
|
(unwind-protect
|
|
(dolist (dir
|
|
'("~/Downloads" "/sftp::~/Downloads" "/ssh::~/Downloads"
|
|
"http://ftp.debian.org/debian/pool/main/c/coreutils"))
|
|
(dolist
|
|
(file
|
|
'("coreutils_8.26-3_amd64.deb"
|
|
"coreutils_8.26-3ubuntu3_amd64.deb"))
|
|
(setq file (expand-file-name file dir))
|
|
(when (file-exists-p file)
|
|
(setq file (expand-file-name "control.tar.gz/control" file))
|
|
(message "%s" file)
|
|
(should (file-attributes (file-name-as-directory file))))))
|
|
|
|
;; Cleanup.
|
|
(tramp-archive-cleanup-hash))
|
|
|
|
(unwind-protect
|
|
(dolist (dir '("" "/sftp::" "/ssh::"))
|
|
(dolist
|
|
(file
|
|
(apply
|
|
'append
|
|
(mapcar
|
|
(lambda (x)
|
|
(directory-files (concat dir x) 'full (rx "uu" eos) 'sort))
|
|
'("~/src/libarchive-3.2.2/libarchive/test"
|
|
"~/src/libarchive-3.2.2/cpio/test"
|
|
"~/src/libarchive-3.2.2/tar/test"))))
|
|
(setq file (file-name-as-directory file))
|
|
(cond
|
|
((not (tramp-archive-file-name-p file))
|
|
(message "skipped: %s" file))
|
|
((file-attributes file)
|
|
(message "%s" file))
|
|
(t (message "failed: %s" file)))
|
|
(tramp-archive-cleanup-hash)))
|
|
|
|
;; Cleanup.
|
|
(tramp-archive-cleanup-hash)))
|
|
|
|
(defun tramp-archive-test-all (&optional interactive)
|
|
"Run all tests for \\[tramp-archive].
|
|
If INTERACTIVE is non-nil, the tests are run interactively."
|
|
(interactive "p")
|
|
(funcall
|
|
(if interactive #'ert-run-tests-interactively #'ert-run-tests-batch)
|
|
"^tramp-archive"))
|
|
|
|
(provide 'tramp-archive-tests)
|
|
|
|
;;; tramp-archive-tests.el ends here
|