[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] master d338325 3/3: Support for archive file names
|
From: |
Michael Albinus |
|
Subject: |
[Emacs-diffs] master d338325 3/3: Support for archive file names |
|
Date: |
Sat, 9 Dec 2017 08:35:17 -0500 (EST) |
branch: master
commit d338325c2b603db8433c9b6b12216201d5ee21e9
Author: Michael Albinus <address@hidden>
Commit: Michael Albinus <address@hidden>
Support for archive file names
* doc/misc/tramp.texi (Top, Usage): Add entry "Archive file names".
(History): Mention archive file names.
(GVFS based methods): Mentio "http" and "https" methods.
(Archive file names): New node.
(Frequently Asked Questions): Add Emacs 27 as supported version.
* etc/NEWS: Mention tramp-archive.el.
* lisp/net/tramp.el (tramp-run-real-handler)
(tramp-register-file-name-handlers)
(tramp-register-file-name-handlers, tramp-unload-file-name-handlers):
Add `tramp-archive-file-name-handler'.
(tramp-handle-file-name-completion): Do not insist in Tramp
file names.
* lisp/net/tramp-archive.el: New package.
* lisp/net/tramp-cache.el (tramp-dump-connection-properties): Check for
"archive" method.
* lisp/net/tramp-cmds.el (tramp-cleanup-all-connections): Cleanup also
local copies of archives.
* lisp/net/tramp-compat.el (tramp-compat-use-url-tramp-p): New defconst.
* lisp/net/tramp-gvfs.el (tramp-gvfs-methods): Add "http" and "https".
(tramp-gvfs-gio-mapping): Add "gvfs-mount".
(tramp-gvfs-handler-mounted-unmounted)
(tramp-gvfs-connection-mounted-p, tramp-gvfs-mount-spec):
Handle "uri" and "http".
(tramp-gvfs-unmount): New defun.
* test/lisp/net/tramp-archive-tests.el: New package.
---
doc/misc/tramp.texi | 216 +++++-
etc/NEWS | 6 +
lisp/net/tramp-archive.el | 556 ++++++++++++++++
lisp/net/tramp-cache.el | 2 +
lisp/net/tramp-cmds.el | 3 +
lisp/net/tramp-compat.el | 16 +-
lisp/net/tramp-gvfs.el | 50 +-
lisp/net/tramp.el | 15 +-
test/lisp/net/tramp-archive-resources/bar/bar | 1 +
test/lisp/net/tramp-archive-resources/foo.hrd | 1 +
test/lisp/net/tramp-archive-resources/foo.lnk | 1 +
test/lisp/net/tramp-archive-resources/foo.tar.gz | Bin 0 -> 234 bytes
test/lisp/net/tramp-archive-resources/foo.txt | 1 +
test/lisp/net/tramp-archive-tests.el | 796 +++++++++++++++++++++++
14 files changed, 1646 insertions(+), 18 deletions(-)
diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi
index e7d9cb1..3869e19 100644
--- a/doc/misc/tramp.texi
+++ b/doc/misc/tramp.texi
@@ -164,6 +164,7 @@ Using @value{tramp}
* Ad-hoc multi-hops:: Declaring multiple hops in the file name.
* Remote processes:: Integration with other Emacs packages.
* Cleanup remote connections:: Cleanup remote connections.
+* Archive file names:: Access to files in file archives.
How file names, directories and localnames are mangled and managed
@@ -407,7 +408,8 @@ since April 2007 (and removed in December 2016). GVFS
integration
started in February 2009. Remote commands on MS Windows hosts since
September 2011. Ad-hoc multi-hop methods (with a changed syntax)
re-enabled in November 2011. In November 2012, added Juergen
-Hoetzel's @file{tramp-adb.el}.
+Hoetzel's @file{tramp-adb.el}. Archive file names are supported since
+December 2017.
XEmacs support was stopped in January 2016. Since March 2017,
@value{tramp} syntax mandates a method.
@@ -1134,7 +1136,10 @@ requires the SYNCE-GVFS plugin.
This user option is a list of external methods for address@hidden By default,
this list includes @option{afp}, @option{dav}, @option{davs},
@option{gdrive}, @option{obex}, @option{sftp} and @option{synce}.
-Other methods to include are: @option{ftp} and @option{smb}.
+Other methods to include are @option{ftp}, @option{http},
address@hidden and @option{smb}. These methods are not intended to be
+used directly as GVFS based method. Instead, they are added here for
+the benefit of @ref{Archive file names}.
@end defopt
@@ -2284,6 +2289,7 @@ is a feature of Emacs that may cause missed prompts when
using
* Ad-hoc multi-hops:: Declaring multiple hops in the file name.
* Remote processes:: Integration with other Emacs packages.
* Cleanup remote connections:: Cleanup remote connections.
+* Archive file names:: Access to files in file archives.
@end menu
@@ -2913,6 +2919,209 @@ that remote connection.
@end deffn
address@hidden Archive file names
address@hidden Archive file names
address@hidden file archives
address@hidden archive file names
address@hidden method archive
address@hidden archive method
+
address@hidden offers also transparent access to files inside file
+archives. This is possible only on machines which have installed the
+virtual file system for the Gnome Desktop (GVFS), @ref{GVFS based
+methods}. Internally, file archives are mounted via the GVFS
address@hidden method.
+
+A file archive is a regular file of kind @file{/path/to/dir/file.EXT}.
+The extension @samp{.EXT} identifies the type of the file archive. A
+file inside a file archive, called archive file name, has the name
address@hidden/path/to/dir/file.EXT/dir/file}.
+
+Most of the @ref{Magic File Names, , magic file name operations,
+elisp}, are implemented for archive file names, exceptions are all
+operations which write into a file archive, and process related
+operations. Therefore, functions like
+
address@hidden
+(copy-file "/path/to/dir/file.tar/dir/file" "/somewhere/else")
address@hidden lisp
+
address@hidden
+work out of the box. This is also true for file name completion, and
+for libraries like @code{dired} or @code{ediff}, which accept archive
+file names as well.
+
address@hidden tramp-archive-suffixes
+File archives are identified by the file name extension @samp{.EXT}.
+Since GVFS uses internally the library @code{libarchive(3)}, all
+suffixes, which are accepted by this library, work also for archive
+file names. Accepted suffixes are listed in the constant
address@hidden They are
+
address@hidden
address@hidden @samp{.7z} ---
+7-Zip archives
address@hidden 7z, file archive suffix
address@hidden file archive suffix 7z
+
address@hidden @samp{.apk} ---
+Android package kits
address@hidden apk, file archive suffix
address@hidden file archive suffix apk
+
address@hidden @samp{.ar} ---
+UNIX archiver formats
address@hidden ar, file archive suffix
address@hidden file archive suffix ar
+
address@hidden @samp{.cab}, @samp{.CAB} ---
+Microsoft Windows cabinets
address@hidden cab, file archive suffix
address@hidden CAB, file archive suffix
address@hidden file archive suffix cab
address@hidden file archive suffix CAB
+
address@hidden @samp{.cpio} ---
+CPIO archives
address@hidden cpio, file archive suffix
address@hidden file archive suffix cpio
+
address@hidden @samp{.deb} ---
+Debian packages
address@hidden deb, file archive suffix
address@hidden file archive suffix deb
+
address@hidden @samp{.depot} ---
+HP-UX SD depots
address@hidden depot, file archive suffix
address@hidden file archive suffix depot
+
address@hidden @samp{.exe} ---
+Self extracting Microsoft Windows EXE files
address@hidden exe, file archive suffix
address@hidden file archive suffix exe
+
address@hidden @samp{.iso} ---
+ISO 9660 images
address@hidden iso, file archive suffix
address@hidden file archive suffix iso
+
address@hidden @samp{.jar} ---
+Java archives
address@hidden jar, file archive suffix
address@hidden file archive suffix jar
+
address@hidden @samp{.lzh}, @samp{LZH} ---
+Microsoft Windows compressed LHA archives
address@hidden lzh, file archive suffix
address@hidden LZH, file archive suffix
address@hidden file archive suffix lzh
address@hidden file archive suffix LZH
+
address@hidden @samp{.mtree} ---
+BSD mtree format
address@hidden mtree, file archive suffix
address@hidden file archive suffix mtree
+
address@hidden @samp{.pax} ---
+Posix archives
address@hidden pax, file archive suffix
address@hidden file archive suffix pax
+
address@hidden @samp{.rar} ---
+RAR archives
address@hidden rar, file archive suffix
address@hidden file archive suffix rar
+
address@hidden @samp{.rpm} ---
+Red Hat packages
address@hidden rpm, file archive suffix
address@hidden file archive suffix rpm
+
address@hidden @samp{.shar} ---
+Shell archives
address@hidden shar, file archive suffix
address@hidden file archive suffix shar
+
address@hidden @samp{.tar}, @samp{tbz}, @samp{tgz}, @samp{tlz}, @samp{txz} ---
+(Compressed) tape archives
address@hidden tar, file archive suffix
address@hidden tbz, file archive suffix
address@hidden tgz, file archive suffix
address@hidden tlz, file archive suffix
address@hidden txz, file archive suffix
address@hidden file archive suffix tar
address@hidden file archive suffix tbz
address@hidden file archive suffix tgz
address@hidden file archive suffix tlz
address@hidden file archive suffix txz
+
address@hidden @samp{.warc} ---
+Web archives
address@hidden warc, file archive suffix
address@hidden file archive suffix warc
+
address@hidden @samp{.xar} ---
+macOS XAR archives
address@hidden xar, file archive suffix
address@hidden file archive suffix xar
+
address@hidden @samp{.xps} ---
+Open XML Paper Specification (OpenXPS) documents
address@hidden xps, file archive suffix
address@hidden file archive suffix xps
+
address@hidden @samp{.zip}, @samp{.ZIP} ---
+ZIP archives
address@hidden zip, file archive suffix
address@hidden ZIP, file archive suffix
address@hidden file archive suffix zip
address@hidden file archive suffix ZIP
address@hidden itemize
+
address@hidden tramp-archive-compression-suffixes
+File archives could also be compressed, identified by an additional
+compression suffix. Valid compression suffixes are listed in the
+constant @code{tramp-archive-compression-suffixes}. They are
address@hidden, @samp{.gz}, @samp{.lrz}, @samp{.lz}, @samp{.lz4},
address@hidden, @samp{.lzo}, @samp{.uu}, @samp{.xz} and @samp{.Z}. A
+valid archive file name would be
address@hidden/path/to/dir/file.tar.gz/dir/file}. Even several suffixes in a
+row are possible, like @file{/path/to/dir/file.tar.gz.uu/dir/file}.
+
address@hidden tramp-archive-all-gvfs-methods
+An archive file name could be a remote file name, as in
address@hidden/ftp:anonymous@@ftp.gnu.org:/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL}.
+Since all file operations are mapped internally to GVFS operations,
+remote file names supported by @code{tramp-gvfs} perform better,
+because no local copy of the file archive must be downloaded first.
+For example, @samp{/sftp:user@@host:...} performs better than the
+similar @samp{/scp:user@@host:...}. See the constant
address@hidden for a complete list of
address@hidden supported method names.
+
+If @code{url-handler-mode} is enabled, archives could be visited via
+URLs, like @file{https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL}.
+This allows complex file operations like
+
address@hidden
address@hidden
+(ediff-directories
+ "https://ftp.gnu.org/gnu/tramp/tramp-2.3.1.tar.gz/tramp-2.3.1";
+ "https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/tramp-2.3.2"; "")
address@hidden group
address@hidden lisp
+
+It is even possible to access file archives in file archives, as
+
address@hidden
address@hidden
+(find-file
+
"http://ftp.debian.org/debian/pool/main/c/coreutils/coreutils_8.28-1_amd64.deb/control.tar.gz/control";)
address@hidden group
address@hidden lisp
+
+
@node Bug Reports
@chapter Reporting Bugs and Problems
@cindex bug reports
@@ -2997,7 +3206,8 @@ Where is the latest @value{tramp}?
@item
Which systems does it work on?
-The package works successfully on Emacs 24, Emacs 25, and Emacs 26.
+The package works successfully on Emacs 24, Emacs 25, Emacs 26, and
+Emacs 27.
While Unix and Unix-like systems are the primary remote targets,
@value{tramp} has equal success connecting to other platforms, such as
diff --git a/etc/NEWS b/etc/NEWS
index cbd50f0..0165768 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -125,6 +125,12 @@ To restore the old behavior, use
* New Modes and Packages in Emacs 27.1
++++
+** The package tramp-archive.el brings file name handler support for
+file archives. It works on systems which support GVFS, which is
+GNU/Linux, roughly spoken. See the chapter "(tramp) Archive file
+names" in the Tramp manual for full documentation of these facilities.
+
* Incompatible Lisp Changes in Emacs 27.1
diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el
new file mode 100644
index 0000000..d1e4804
--- /dev/null
+++ b/lisp/net/tramp-archive.el
@@ -0,0 +1,556 @@
+;;; tramp-archive.el --- Tramp archive manager -*- lexical-binding:t -*-
+
+;; Copyright (C) 2017 Free Software Foundation, Inc.
+
+;; Author: Michael Albinus <address@hidden>
+;; Keywords: comm, processes
+;; Package: tramp
+
+;; 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:
+
+;; Access functions for file archives. This is possible only on
+;; machines which have installed the virtual file system for the Gnome
+;; Desktop (GVFS). Internally, file archives are mounted via the GVFS
+;; "archive" method.
+
+;; A file archive is a regular file of kind "/path/to/dir/file.EXT".
+;; The extension ".EXT" identifies the type of the file archive. A
+;; file inside a file archive, called archive file name, has the name
+;; "/path/to/dir/file.EXT/dir/file".
+
+;; Most of the magic file name operations are implemented for archive
+;; file names, exceptions are all operations which write into a file
+;; archive, and process related operations. Therefore, functions like
+
+;; (copy-file "/path/to/dir/file.tar/dir/file" "/somewhere/else")
+
+;; work out of the box. This is also true for file name completion,
+;; and for libraries like `dired' or `ediff', which accept archive
+;; file names as well.
+
+;; File archives are identified by the file name extension ".EXT".
+;; Since GVFS uses internally the library libarchive(3), all suffixes,
+;; which are accepted by this library, work also for archive file
+;; names. Accepted suffixes are listed in the constant
+;; `tramp-archive-suffixes'. They are
+
+;; * ".7z" - 7-Zip archives
+;; * ".apk" - Android package kits
+;; * ".ar" - UNIX archiver formats
+;; * ".cab", ".CAB" - Microsoft Windows cabinets
+;; * ".cpio" - CPIO archives
+;; * ".deb" - Debian packages
+;; * ".depot" - HP-UX SD depots
+;; * ".exe" - Self extracting Microsoft Windows EXE files
+;; * ".iso" - ISO 9660 images
+;; * ".jar" - Java archives
+;; * ".lzh", "LZH" - Microsoft Windows compressed LHA archives
+;; * ".mtree" - BSD mtree format
+;; * ".pax" - Posix archives
+;; * ".rar" - RAR archives
+;; * ".rpm" - Red Hat packages
+;; * ".shar" - Shell archives
+;; * ".tar", "tbz", "tgz", "tlz", "txz" - (Compressed) tape archives
+;; * ".warc" - Web archives
+;; * ".xar" - macOS XAR archives
+;; * ".xps" - Open XML Paper Specification (OpenXPS) documents
+;; * ".zip", ".ZIP" - ZIP archives
+
+;; File archives could also be compressed, identified by an additional
+;; compression suffix. Valid compression suffixes are listed in the
+;; constant `tramp-archive-compression-suffixes'. They are ".bz2",
+;; ".gz", ".lrz", ".lz", ".lz4", ".lzma", ".lzo", ".uu", ".xz" and
+;; ".Z". A valid archive file name would be
+;; "/path/to/dir/file.tar.gz/dir/file". Even several suffixes in a
+;; row are possible, like "/path/to/dir/file.tar.gz.uu/dir/file".
+
+;; An archive file name could be a remote file name, as in
+;; "/ftp:address@hidden:/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL".
+;; Since all file operations are mapped internally to GVFS operations,
+;; remote file names supported by tramp-gvfs.el perform better,
+;; because no local copy of the file archive must be downloaded first.
+;; For example, "/sftp:address@hidden:..." performs better than the similar
+;; "/scp:address@hidden:...". See the constant
+;; `tramp-archive-all-gvfs-methods' for a complete list of
+;; tramp-gvfs.el supported method names.
+
+;; If `url-handler-mode' is enabled, archives could be visited via
+;; URLs, like "https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL";.
+;; This allows complex file operations like
+
+;; (ediff-directories
+;; "https://ftp.gnu.org/gnu/tramp/tramp-2.3.1.tar.gz/tramp-2.3.1";
+;; "https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/tramp-2.3.2"; "")
+
+;; It is even possible to access file archives in file archives, as
+
+;; (find-file
+;;
"http://ftp.debian.org/debian/pool/main/c/coreutils/coreutils_8.28-1_amd64.deb/control.tar.gz/control";)
+
+;;; Code:
+
+(require 'tramp-gvfs)
+
+(autoload 'dired-uncache "dired")
+(autoload 'url-tramp-convert-url-to-tramp "url-tramp")
+(defvar url-handler-mode-hook)
+(defvar url-handler-regexp)
+(defvar url-tramp-protocols)
+
+;; <https://github.com/libarchive/libarchive/wiki/LibarchiveFormats>
+;;;###tramp-autoload
+(defconst tramp-archive-suffixes
+ ;; "cab", "lzh" and "zip" are included with lower and upper letters,
+ ;; because Microsoft Windows provides them often with capital
+ ;; letters.
+ '("7z" ;; 7-Zip archives.
+ "apk" ;; Android package kits. Not in libarchive testsuite.
+ "ar" ;; UNIX archiver formats.
+ "cab" "CAB" ;; Microsoft Windows cabinets.
+ "cpio" ;; CPIO archives.
+ "deb" ;; Debian packages. Not in libarchive testsuite.
+ "depot" ;; HP-UX SD depot. Not in libarchive testsuite.
+ "exe" ;; Self extracting Microsoft Windows EXE files.
+ "iso" ;; ISO 9660 images.
+ "jar" ;; Java archives. Not in libarchive testsuite.
+ "lzh" "LZH" ;; Microsoft Windows compressed LHA archives.
+ "mtree" ;; BSD mtree format.
+ "pax" ;; Posix archives.
+ "rar" ;; RAR archives.
+ "rpm" ;; Red Hat packages.
+ "shar" ;; Shell archives. Not in libarchive testsuite.
+ "tar" "tbz" "tgz" "tlz" "txz" ;; (Compressed) tape archives.
+ "warc" ;; Web archives.
+ "xar" ;; macOS XAR archives. Not in libarchive testsuite.
+ "xps" ;; Open XML Paper Specification (OpenXPS) documents.
+ "zip" "ZIP") ;; ZIP archives.
+ "List of suffixes which indicate a file archive.
+It must be supported by libarchive(3).")
+
+;; <http://unix-memo.readthedocs.io/en/latest/vfs.html>
+;; read and write: tar, cpio, pax , gzip , zip, bzip2, xz, lzip, lzma, ar,
mtree, iso9660, compress,
+;; read only: 7-Zip, mtree, xar, lha/lzh, rar, microsoft cab,
+
+;;;###tramp-autoload
+(defconst tramp-archive-compression-suffixes
+ '("bz2" "gz" "lrz" "lz" "lz4" "lzma" "lzo" "uu" "xz" "Z")
+ "List of suffixes which indicate a compressed file.
+It must be supported by libarchive(3).")
+
+;;;###tramp-autoload
+(defconst tramp-archive-file-name-regexp
+ (concat
+ "\\`" "\\(" ".+" "\\."
+ ;; Default suffixes ...
+ (regexp-opt tramp-archive-suffixes)
+ ;; ... with compression.
+ "\\(?:" "\\." (regexp-opt tramp-archive-compression-suffixes) "\\)*"
+ "\\)" ;; \1
+ "\\(" "/" ".*" "\\)" "\\'") ;; \2
+ "Regular expression matching archive file names.")
+
+;;;###tramp-autoload
+(defconst tramp-archive-method "archive"
+ "Method name for archives in GVFS.")
+
+(defconst tramp-archive-all-gvfs-methods
+ (cons tramp-archive-method
+ (let ((values (cdr (cadr (get 'tramp-gvfs-methods 'custom-type)))))
+ (setq values (mapcar 'last values)
+ values (mapcar 'car values))))
+ "List of all methods `tramp-gvfs-methods' offers.")
+
+
+;; New handlers should be added here.
+;;;###tramp-autoload
+(defconst tramp-archive-file-name-handler-alist
+ '((access-file . ignore)
+ (add-name-to-file . tramp-archive-handle-not-implemented)
+ ;; `byte-compiler-base-file-name' performed by default handler.
+ ;; `copy-directory' performed by default handler.
+ (copy-file . tramp-archive-handle-copy-file)
+ (delete-directorye . tramp-archive-handle-not-implemented)
+ (delete-file . tramp-archive-handle-not-implemented)
+ ;; `diff-latest-backup-file' performed by default handler.
+ (directory-file-name . tramp-archive-handle-directory-file-name)
+ (directory-files . tramp-handle-directory-files)
+ (directory-files-and-attributes
+ . tramp-handle-directory-files-and-attributes)
+ (dired-compress-file . tramp-archive-handle-not-implemented)
+ (dired-uncache . tramp-archive-handle-dired-uncache)
+ ;; `expand-file-name' performed by default handler.
+ (file-accessible-directory-p . tramp-handle-file-accessible-directory-p)
+ (file-acl . ignore)
+ (file-attributes . tramp-archive-handle-file-attributes)
+ (file-directory-p . tramp-handle-file-directory-p)
+ (file-equal-p . tramp-handle-file-equal-p)
+ (file-executable-p . tramp-archive-handle-file-executable-p)
+ (file-exists-p . tramp-handle-file-exists-p)
+ (file-in-directory-p . tramp-handle-file-in-directory-p)
+ (file-local-copy . tramp-archive-handle-file-local-copy)
+ (file-modes . tramp-handle-file-modes)
+ (file-name-all-completions .
tramp-archive-handle-file-name-all-completions)
+ ;; `file-name-as-directory' performed by default handler.
+ (file-name-case-insensitive-p . ignore)
+ (file-name-completion . tramp-handle-file-name-completion)
+ ;; `file-name-directory' performed by default handler.
+ ;; `file-name-nondirectory' performed by default handler.
+ ;; `file-name-sans-versions' performed by default handler.
+ (file-newer-than-file-p . tramp-handle-file-newer-than-file-p)
+ (file-notify-add-watch . ignore)
+ (file-notify-rm-watch . ignore)
+ (file-notify-valid-p . ignore)
+ (file-ownership-preserved-p . ignore)
+ (file-readable-p . tramp-archive-handle-file-readable-p)
+ (file-regular-p . tramp-handle-file-regular-p)
+ ;; `file-remote-p' performed by default handler.
+ (file-selinux-context . tramp-handle-file-selinux-context)
+ (file-symlink-p . tramp-handle-file-symlink-p)
+ (file-system-info . tramp-archive-handle-file-system-info)
+ (file-truename . tramp-archive-handle-file-truename)
+ (file-writable-p . ignore)
+ (find-backup-file-name . ignore)
+ ;; `find-file-noselect' performed by default handler.
+ ;; `get-file-buffer' performed by default handler.
+ (insert-directory . tramp-archive-handle-insert-directory)
+ (insert-file-contents . tramp-archive-handle-insert-file-contents)
+ (load . tramp-archive-handle-load)
+ (make-auto-save-file-name . ignore)
+ (make-directory . tramp-archive-handle-not-implemented)
+ (make-directory-internal . tramp-archive-handle-not-implemented)
+ (make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
+ (make-symbolic-link . tramp-archive-handle-not-implemented)
+ (process-file . ignore)
+ (rename-file . tramp-archive-handle-not-implemented)
+ (set-file-acl . ignore)
+ (set-file-modes . tramp-archive-handle-not-implemented)
+ (set-file-selinux-context . ignore)
+ (set-file-times . tramp-archive-handle-not-implemented)
+ (set-visited-file-modtime . tramp-handle-set-visited-file-modtime)
+ (shell-command . tramp-archive-handle-not-implemented)
+ (start-file-process . tramp-archive-handle-not-implemented)
+ ;; `substitute-in-file-name' performed by default handler.
+ ;; `temporary-file-directory' performed by default handler.
+ (unhandled-file-name-directory . ignore)
+ (vc-registered . ignore)
+ (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
+ (write-region . tramp-archive-handle-not-implemented))
+ "Alist of handler functions for GVFS archive method.
+Operations not mentioned here will be handled by the default Emacs
primitives.")
+
+;;;###tramp-autoload
+(defun tramp-archive-file-name-handler (operation &rest args)
+ "Invoke the GVFS archive related OPERATION.
+First arg specifies the OPERATION, second arg is a list of arguments to
+pass to the OPERATION."
+ (unless tramp-gvfs-enabled
+ (tramp-compat-user-error nil "Package `tramp-archive' not supported"))
+ (let ((tramp-methods (cons `(,tramp-archive-method) tramp-methods))
+ (tramp-gvfs-methods tramp-archive-all-gvfs-methods)
+ (fn (assoc operation tramp-archive-file-name-handler-alist)))
+ (when (eq (cdr fn) 'tramp-archive-handle-not-implemented)
+ (setq args (cons operation args)))
+ (if fn
+ (save-match-data (apply (cdr fn) args))
+ (tramp-run-real-handler operation args))))
+
+;; Mark `operations' the handler is responsible for.
+(put 'tramp-archive-file-name-handler 'operations
+ (mapcar 'car tramp-archive-file-name-handler-alist))
+
+;; `tramp-archive-file-name-handler' must be placed before `url-file-handler'.
+(when url-handler-mode (tramp-register-file-name-handlers))
+
+(eval-after-load 'url-handler
+ (progn
+ (add-hook 'url-handler-mode-hook 'tramp-register-file-name-handlers)
+ (add-hook
+ 'tramp-archive-unload-hook
+ (lambda ()
+ (remove-hook
+ 'url-handler-mode-hook 'tramp-register-file-name-handlers)))))
+
+;; Debug.
+;(trace-function-background 'tramp-archive-file-name-handler)
+;(trace-function-background 'tramp-gvfs-file-name-handler)
+;(trace-function-background 'tramp-file-name-archive)
+;(trace-function-background 'tramp-archive-dissect-file-name)
+
+
+;; File name conversions.
+
+(defun tramp-archive-file-name-p (name)
+ "Return t if NAME is a string with archive file name syntax."
+ (and (stringp name)
+ (string-match tramp-archive-file-name-regexp name)
+ t))
+
+(defvar tramp-archive-hash (make-hash-table :test 'equal)
+ "Hash table for archive local copies.")
+
+(defun tramp-archive-local-copy (archive)
+ "Return copy of ARCHIVE, usable by GVFS.
+ARCHIVE is the archive component of an archive file name."
+ (setq archive (file-truename archive))
+ (let ((tramp-verbose 0))
+ (with-tramp-connection-property
+ ;; This is just an auxiliary VEC for caching properties.
+ (make-tramp-file-name :method tramp-archive-method :host archive)
+ "archive"
+ (cond
+ ;; File archives inside file archives.
+ ((tramp-archive-file-name-p archive)
+ (let ((archive
+ (tramp-make-tramp-file-name
+ (tramp-archive-dissect-file-name archive) nil 'noarchive)))
+ ;; We call `file-attributes' in order to mount the archive.
+ (file-attributes archive)
+ (puthash archive nil tramp-archive-hash)
+ archive))
+ ;; http://...
+ ((and url-handler-mode
+ tramp-compat-use-url-tramp-p
+ (string-match url-handler-regexp archive)
+ (string-match "https?" (url-type (url-generic-parse-url archive))))
+ (let* ((url-tramp-protocols
+ (cons
+ (url-type (url-generic-parse-url archive))
+ url-tramp-protocols))
+ (archive (url-tramp-convert-url-to-tramp archive)))
+ (puthash archive nil tramp-archive-hash)
+ archive))
+ ;; GVFS supported schemes.
+ ((or (tramp-gvfs-file-name-p archive)
+ (not (file-remote-p archive)))
+ (puthash archive nil tramp-archive-hash)
+ archive)
+ ;; Anything else. Here we call `file-local-copy', which we
+ ;; have avoided so far.
+ (t (let ((inhibit-file-name-operation 'file-local-copy)
+ (inhibit-file-name-handlers
+ (cons 'jka-compr-handler inhibit-file-name-handlers))
+ result)
+ (or (and (setq result (gethash archive tramp-archive-hash nil))
+ (file-readable-p result))
+ (puthash
+ archive
+ (setq result (file-local-copy archive))
+ tramp-archive-hash))
+ result))))))
+
+;;;###tramp-autoload
+(defun tramp-archive-cleanup-hash ()
+ "Remove local copies of archives, used by GVFS."
+ (maphash
+ (lambda (key value)
+ ;; Unmount local copy.
+ (ignore-errors
+ (let ((tramp-gvfs-methods tramp-archive-all-gvfs-methods)
+ (file-archive (file-name-as-directory key)))
+ (tramp-message
+ (and (tramp-tramp-file-p key) (tramp-dissect-file-name key)) 3
+ "Unmounting %s" file-archive)
+ (tramp-gvfs-unmount
+ (tramp-dissect-file-name
+ (tramp-archive-gvfs-file-name file-archive)))))
+ ;; Delete local copy.
+ (ignore-errors (when value (delete-file value)))
+ (remhash key tramp-archive-hash))
+ tramp-archive-hash)
+ (clrhash tramp-archive-hash))
+
+(add-hook 'kill-emacs-hook 'tramp-archive-cleanup-hash)
+(add-hook 'tramp-archive-unload-hook
+ (lambda ()
+ (remove-hook 'kill-emacs-hook
+ 'tramp-archive-cleanup-hash)))
+
+(defun tramp-archive-dissect-file-name (name)
+ "Return a `tramp-file-name' structure.
+The structure consists of the `tramp-archive-method' method, the
+hexlified archive name as host, and the localname. The archive
+name is kept in slot `hop'"
+ (save-match-data
+ (unless (tramp-archive-file-name-p name)
+ (tramp-compat-user-error nil "Not an archive file name: \"%s\"" name))
+ ;; The `string-match' happened in `tramp-archive-file-name-p'.
+ (let ((archive (match-string 1 name))
+ (localname (match-string 2 name))
+ (tramp-verbose 0))
+ (make-tramp-file-name
+ :method tramp-archive-method :user nil :domain nil :host
+ (url-hexify-string
+ (tramp-gvfs-url-file-name (tramp-archive-local-copy archive)))
+ :port nil :localname localname :hop archive))))
+
+(defsubst tramp-file-name-archive (vec)
+ "Extract the archive file name from VEC.
+VEC is expected to be a `tramp-file-name', with the method being
+`tramp-archive-method', and the host being a coded URL. The
+archive name is extracted from the hop part of the VEC structure."
+ (and (tramp-file-name-p vec)
+ (string-equal (tramp-file-name-method vec) tramp-archive-method)
+ (tramp-file-name-hop vec)))
+
+(defmacro with-parsed-tramp-archive-file-name (filename var &rest body)
+ "Parse an archive filename and make components available in the body.
+This works exactly as `with-parsed-tramp-file-name' for the Tramp
+file name structure returned by `tramp-archive-dissect-file-name'.
+A variable `foo-archive' (or `archive') will be bound to the
+archive name part of FILENAME, assuming `foo' (or nil) is the
+value of VAR. OTOH, the variable `foo-hop' (or `hop') won't be
+offered."
+ (declare (debug (form symbolp body))
+ (indent 2))
+ (let ((bindings
+ (mapcar (lambda (elem)
+ `(,(if var (intern (format "%s-%s" var elem)) elem)
+ (,(intern (format "tramp-file-name-%s" elem))
+ ,(or var 'v))))
+ `,(cons
+ 'archive
+ (delete 'hop (tramp-compat-tramp-file-name-slots))))))
+ `(let* ((,(or var 'v) (tramp-archive-dissect-file-name ,filename))
+ ,@bindings)
+ ;; We don't know which of those vars will be used, so we bind them all,
+ ;; and then add here a dummy use of all those variables, so we don't get
+ ;; flooded by warnings about those vars `body' didn't use.
+ (ignore ,@(mapcar #'car bindings))
+ ,@body)))
+
+(defun tramp-archive-gvfs-file-name (name)
+ "Return FILENAME in GVFS syntax."
+ (tramp-make-tramp-file-name
+ (tramp-archive-dissect-file-name name) nil 'nohop))
+
+
+;; File name primitives.
+
+(defun tramp-archive-handle-copy-file
+ (filename newname &optional ok-if-already-exists keep-date
+ preserve-uid-gid preserve-extended-attributes)
+ "Like `copy-file' for file archives."
+ (when (tramp-archive-file-name-p newname)
+ (tramp-error
+ (tramp-archive-dissect-file-name newname) 'file-error
+ "Permission denied: %s" newname))
+ (copy-file
+ (tramp-archive-gvfs-file-name filename) newname ok-if-already-exists
+ keep-date preserve-uid-gid preserve-extended-attributes))
+
+(defun tramp-archive-handle-directory-file-name (directory)
+ "Like `directory-file-name' for file archives."
+ (with-parsed-tramp-archive-file-name directory nil
+ (if (and (not (zerop (length localname)))
+ (eq (aref localname (1- (length localname))) ?/)
+ (not (string= localname "/")))
+ (substring directory 0 -1)
+ ;; We do not want to leave the file archive. This would require
+ ;; unnecessary download of http-based file archives, for
+ ;; example. So we return `directory'.
+ directory)))
+
+(defun tramp-archive-handle-dired-uncache (dir)
+ "Like `dired-uncache' for file archives."
+ (dired-uncache (tramp-archive-gvfs-file-name dir)))
+
+(defun tramp-archive-handle-file-attributes (filename &optional id-format)
+ "Like `file-attributes' for file archives."
+ (file-attributes (tramp-archive-gvfs-file-name filename) id-format))
+
+(defun tramp-archive-handle-file-executable-p (filename)
+ "Like `file-executable-p' for file archives."
+ (file-executable-p (tramp-archive-gvfs-file-name filename)))
+
+(defun tramp-archive-handle-file-local-copy (filename)
+ "Like `file-local-copy' for file archives."
+ (file-local-copy (tramp-archive-gvfs-file-name filename)))
+
+(defun tramp-archive-handle-file-name-all-completions (filename directory)
+ "Like `file-name-all-completions' for file archives."
+ (file-name-all-completions filename (tramp-archive-gvfs-file-name
directory)))
+
+(defun tramp-archive-handle-file-readable-p (filename)
+ "Like `file-readable-p' for file archives."
+ (with-parsed-tramp-file-name
+ (tramp-archive-gvfs-file-name filename) nil
+ (tramp-check-cached-permissions v ?r)))
+
+(defun tramp-archive-handle-file-system-info (filename)
+ "Like `file-system-info' for file archives."
+ (with-parsed-tramp-archive-file-name filename nil
+ (list (tramp-compat-file-attribute-size (file-attributes archive)) 0 0)))
+
+(defun tramp-archive-handle-file-truename (filename)
+ "Like `file-truename' for file archives."
+ (with-parsed-tramp-archive-file-name filename nil
+ (let ((local (or (file-symlink-p filename) localname)))
+ (unless (file-name-absolute-p local)
+ (setq local (expand-file-name local (file-name-directory localname))))
+ (concat (file-truename archive) local))))
+
+(defun tramp-archive-handle-insert-directory
+ (filename switches &optional wildcard full-directory-p)
+ "Like `insert-directory' for file archives."
+ (insert-directory
+ (tramp-archive-gvfs-file-name filename) switches wildcard full-directory-p)
+ (goto-char (point-min))
+ (while (search-forward (tramp-archive-gvfs-file-name filename) nil 'noerror)
+ (replace-match filename)))
+
+(defun tramp-archive-handle-insert-file-contents
+ (filename &optional visit beg end replace)
+ "Like `insert-file-contents' for file archives."
+ (let ((result
+ (insert-file-contents
+ (tramp-archive-gvfs-file-name filename) visit beg end replace)))
+ (prog1
+ (list (expand-file-name filename)
+ (cadr result))
+ (when visit (setq buffer-file-name filename)))))
+
+(defun tramp-archive-handle-load
+ (file &optional noerror nomessage nosuffix must-suffix)
+ "Like `load' for file archives."
+ (load
+ (tramp-archive-gvfs-file-name file) noerror nomessage nosuffix must-suffix))
+
+(defun tramp-archive-handle-not-implemented (operation &rest args)
+ "Generic handler for operations not implemented for file archives."
+ (let ((v (ignore-errors
+ (tramp-archive-dissect-file-name
+ (apply 'tramp-file-name-for-operation operation args)))))
+ (tramp-message v 10 "%s" (cons operation args))
+ (tramp-error
+ v 'file-error
+ "Operation `%s' not implemented for file archives" operation)))
+
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'tramp-archive 'force)))
+
+(provide 'tramp-archive)
+
+;;; TODO:
+
+;; * See, whether we could retrieve better file attributes like uid,
+;; gid, permissions.
+;;
+;; * Implement write access, when possible.
+
+;;; tramp-archive.el ends here
diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el
index 87ec3c2..bd746c1 100644
--- a/lisp/net/tramp-cache.el
+++ b/lisp/net/tramp-cache.el
@@ -384,6 +384,8 @@ used to cache connection properties of the local machine."
(maphash
(lambda (key value)
(if (and (tramp-file-name-p key) value
+ (not (string-equal
+ (tramp-file-name-method key) tramp-archive-method))
(not (tramp-file-name-localname key))
(not (gethash "login-as" value))
(not (gethash "started" value)))
diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el
index 35c00a0..1f72e25 100644
--- a/lisp/net/tramp-cmds.el
+++ b/lisp/net/tramp-cmds.el
@@ -143,6 +143,9 @@ This includes password cache, file cache, connection cache,
buffers."
;; Flush file and connection cache.
(clrhash tramp-cache-data)
+ ;; Cleanup local copies of archives.
+ (tramp-archive-cleanup-hash)
+
;; Remove buffers.
(dolist (name (tramp-list-tramp-buffers))
(when (bufferp (get-buffer name)) (kill-buffer name))))
diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el
index 9cdfc06..a9e9ce8 100644
--- a/lisp/net/tramp-compat.el
+++ b/lisp/net/tramp-compat.el
@@ -190,11 +190,6 @@ This is a string of ten letters or dashes as in ls -l."
(if (get 'file-missing 'error-conditions) 'file-missing 'file-error)
"The error symbol for the `file-missing' error.")
-(add-hook 'tramp-unload-hook
- (lambda ()
- (unload-feature 'tramp-loaddefs 'force)
- (unload-feature 'tramp-compat 'force)))
-
;; `file-name-quoted-p', `file-name-quote' and `file-name-unquote' are
;; introduced in Emacs 26.
(eval-and-compile
@@ -243,6 +238,17 @@ If NAME is a remote file name, the local part of NAME is
unquoted."
`(cdr (mapcar 'car (cl-struct-slot-info 'tramp-file-name)))
`(cdr (mapcar 'car (get 'tramp-file-name 'cl-struct-slots)))))
+;; The signature of `tramp-make-tramp-file-name' has been changed.
+;; Therefore, we cannot us `url-tramp-convert-url-to-tramp' prior
+;; Emacs 26.1. We use `temporary-file-directory' as indicator.
+(defconst tramp-compat-use-url-tramp-p (fboundp 'temporary-file-directory)
+ "Whether to use url-tramp.el.")
+
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'tramp-loaddefs 'force)
+ (unload-feature 'tramp-compat 'force)))
+
(provide 'tramp-compat)
;;; TODO:
diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el
index d862e95..a1d50b6 100644
--- a/lisp/net/tramp-gvfs.el
+++ b/lisp/net/tramp-gvfs.el
@@ -54,10 +54,12 @@
;; device, if it hasn't been done already. There might be also some
;; few seconds delay in discovering available bluetooth devices.
-;; Other possible connection methods are "ftp" and "smb". When one of
-;; these methods is added to the list, the remote access for that
-;; method is performed via GVFS instead of the native Tramp
-;; implementation.
+;; Other possible connection methods are "ftp", "http", "https" and
+;; "smb". When one of these methods is added to the list, the remote
+;; access for that method is performed via GVFS instead of the native
+;; Tramp implementation. However, this is not recommended. These
+;; methods are listed here for the benefit of file archives, see
+;; tramp-archive.el.
;; GVFS offers even more connection methods. The complete list of
;; connection methods of the actual GVFS implementation can be
@@ -119,6 +121,8 @@
(const "davs")
(const "ftp")
(const "gdrive")
+ (const "http")
+ (const "https")
(const "obex")
(const "sftp")
(const "smb")
@@ -424,6 +428,7 @@ Every entry is a list (NAME ADDRESS).")
("gvfs-ls" . "list")
("gvfs-mkdir" . "mkdir")
("gvfs-monitor-file" . "monitor")
+ ("gvfs-mount" . "mount")
("gvfs-move" . "move")
("gvfs-rm" . "remove")
("gvfs-trash" . "trash"))
@@ -1455,6 +1460,8 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or
\"[xx:xx:xx:xx:xx:xx]\"."
(cadr (assoc "port" (cadr mount-spec)))))
(ssl (tramp-gvfs-dbus-byte-array-to-string
(cadr (assoc "ssl" (cadr mount-spec)))))
+ (uri (tramp-gvfs-dbus-byte-array-to-string
+ (cadr (assoc "uri" (cadr mount-spec)))))
(prefix (concat
(tramp-gvfs-dbus-byte-array-to-string
(car mount-spec))
@@ -1469,6 +1476,12 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or
\"[xx:xx:xx:xx:xx:xx]\"."
(setq method "davs"))
(when (string-equal "google-drive" method)
(setq method "gdrive"))
+ (when (and (string-equal "http" method) (stringp uri))
+ (setq uri (url-generic-parse-url uri)
+ method (url-type uri)
+ user (url-user uri)
+ host (url-host uri)
+ port (url-portspec uri)))
(with-parsed-tramp-file-name
(tramp-make-tramp-file-name method user domain host port "") nil
(tramp-message
@@ -1537,6 +1550,8 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or
\"[xx:xx:xx:xx:xx:xx]\"."
(cadr (assoc "port" (cadr mount-spec)))))
(ssl (tramp-gvfs-dbus-byte-array-to-string
(cadr (assoc "ssl" (cadr mount-spec)))))
+ (uri (tramp-gvfs-dbus-byte-array-to-string
+ (cadr (assoc "uri" (cadr mount-spec)))))
(prefix (concat
(tramp-gvfs-dbus-byte-array-to-string
(car mount-spec))
@@ -1554,6 +1569,12 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or
\"[xx:xx:xx:xx:xx:xx]\"."
(setq method "gdrive"))
(when (and (string-equal "synce" method) (zerop (length user)))
(setq user (or (tramp-file-name-user vec) "")))
+ (when (and (string-equal "http" method) (stringp uri))
+ (setq uri (url-generic-parse-url uri)
+ method (url-type uri)
+ user (url-user uri)
+ host (url-host uri)
+ port (url-portspec uri)))
(when (and
(string-equal method (tramp-file-name-method vec))
(string-equal user (tramp-file-name-user vec))
@@ -1570,6 +1591,16 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or
\"[xx:xx:xx:xx:xx:xx]\"."
vec "default-location" default-location)
(throw 'mounted t)))))))
+(defun tramp-gvfs-unmount (vec)
+ "Unmount the object identified by VEC."
+ (let ((vec (copy-tramp-file-name vec)))
+ (setf (tramp-file-name-localname vec) "/"
+ (tramp-file-name-hop vec) nil)
+ (when (tramp-gvfs-connection-mounted-p vec)
+ (tramp-gvfs-send-command
+ vec "gvfs-mount" "-u"
+ (tramp-gvfs-url-file-name (tramp-make-tramp-file-name vec))))))
+
(defun tramp-gvfs-mount-spec-entry (key value)
"Construct a mount-spec entry to be used in a mount_spec.
It was \"a(say)\", but has changed to \"a{sv})\"."
@@ -1611,7 +1642,14 @@ It was \"a(say)\", but has changed to \"a{sv})\"."
((string-equal "gdrive" method)
(list (tramp-gvfs-mount-spec-entry "type" "google-drive")
(tramp-gvfs-mount-spec-entry "host" host)))
- (t
+ ((string-match "\\`http" method)
+ (list (tramp-gvfs-mount-spec-entry "type" "http")
+ (tramp-gvfs-mount-spec-entry
+ "uri"
+ (url-recreate-url
+ (url-parse-make-urlobj
+ method user nil host port "/" nil nil t)))))
+ (t
(list (tramp-gvfs-mount-spec-entry "type" method)
(tramp-gvfs-mount-spec-entry "host" host))))
,@(when user
@@ -2033,6 +2071,8 @@ They are retrieved from the hal daemon."
;;; TODO:
+;; * (Customizable) unmount when exiting Emacs. See tramp-archive.el.
+
;; * Host name completion for existing mount points (afp-server,
;; smb-server) or via smb-network.
;;
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index b933778..c73ec1d 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -2064,6 +2064,7 @@ pass to the OPERATION."
`(tramp-file-name-handler
tramp-vc-file-name-handler
tramp-completion-file-name-handler
+ tramp-archive-file-name-handler
cygwin-mount-name-hook-function
cygwin-mount-map-drive-hook-function
.
@@ -2369,12 +2370,14 @@ remote file names."
;; loading of Tramp.
(dolist (fnh '(tramp-file-name-handler
tramp-completion-file-name-handler
+ tramp-archive-file-name-handler
tramp-autoload-file-name-handler))
(let ((a1 (rassq fnh file-name-handler-alist)))
(setq file-name-handler-alist (delq a1 file-name-handler-alist))))
;; Add the handlers. We do not add anything to the `operations'
- ;; property of `tramp-file-name-handler', this shall be done by the
+ ;; property of `tramp-file-name-handler' and
+ ;; `tramp-archive-file-name-handler', this shall be done by the
;; respective foreign handlers.
(add-to-list 'file-name-handler-alist
(cons tramp-file-name-regexp 'tramp-file-name-handler))
@@ -2388,6 +2391,11 @@ remote file names."
(put 'tramp-completion-file-name-handler 'operations
(mapcar 'car tramp-completion-file-name-handler-alist))
+ (add-to-list 'file-name-handler-alist
+ (cons tramp-archive-file-name-regexp
+ 'tramp-archive-file-name-handler))
+ (put 'tramp-archive-file-name-handler 'safe-magic t)
+
;; If jka-compr or epa-file are already loaded, move them to the
;; front of `file-name-handler-alist'.
(dolist (fnh '(epa-file-handler jka-compr-handler))
@@ -2441,6 +2449,7 @@ Add operations defined in `HANDLER-alist' to
`tramp-file-name-handler'."
"Unload Tramp file name handlers from `file-name-handler-alist'."
(dolist (fnh '(tramp-file-name-handler
tramp-completion-file-name-handler
+ tramp-archive-file-name-handler
tramp-autoload-file-name-handler))
(let ((a1 (rassq fnh file-name-handler-alist)))
(setq file-name-handler-alist (delq a1 file-name-handler-alist))))))
@@ -3100,10 +3109,6 @@ User is always nil."
(defun tramp-handle-file-name-completion
(filename directory &optional predicate)
"Like `file-name-completion' for Tramp files."
- (unless (tramp-tramp-file-p directory)
- (error
- "tramp-handle-file-name-completion invoked on non-tramp directory `%s'"
- directory))
(let (hits-ignored-extensions)
(or
(try-completion
diff --git a/test/lisp/net/tramp-archive-resources/bar/bar
b/test/lisp/net/tramp-archive-resources/bar/bar
new file mode 100644
index 0000000..5716ca5
--- /dev/null
+++ b/test/lisp/net/tramp-archive-resources/bar/bar
@@ -0,0 +1 @@
+bar
diff --git a/test/lisp/net/tramp-archive-resources/foo.hrd
b/test/lisp/net/tramp-archive-resources/foo.hrd
new file mode 100644
index 0000000..257cc56
--- /dev/null
+++ b/test/lisp/net/tramp-archive-resources/foo.hrd
@@ -0,0 +1 @@
+foo
diff --git a/test/lisp/net/tramp-archive-resources/foo.lnk
b/test/lisp/net/tramp-archive-resources/foo.lnk
new file mode 120000
index 0000000..996f178
--- /dev/null
+++ b/test/lisp/net/tramp-archive-resources/foo.lnk
@@ -0,0 +1 @@
+foo.txt
\ No newline at end of file
diff --git a/test/lisp/net/tramp-archive-resources/foo.tar.gz
b/test/lisp/net/tramp-archive-resources/foo.tar.gz
new file mode 100644
index 0000000..68925b1
Binary files /dev/null and b/test/lisp/net/tramp-archive-resources/foo.tar.gz
differ
diff --git a/test/lisp/net/tramp-archive-resources/foo.txt
b/test/lisp/net/tramp-archive-resources/foo.txt
new file mode 100644
index 0000000..257cc56
--- /dev/null
+++ b/test/lisp/net/tramp-archive-resources/foo.txt
@@ -0,0 +1 @@
+foo
diff --git a/test/lisp/net/tramp-archive-tests.el
b/test/lisp/net/tramp-archive-tests.el
new file mode 100644
index 0000000..bbe7d4c
--- /dev/null
+++ b/test/lisp/net/tramp-archive-tests.el
@@ -0,0 +1,796 @@
+;;; tramp-archive-tests.el --- Tests of file archive access -*-
lexical-binding:t -*-
+
+;; Copyright (C) 2017 Free Software Foundation, Inc.
+
+;; Author: Michael Albinus <address@hidden>
+
+;; This program 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.
+;;
+;; This program 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 this program. If not, see `https://www.gnu.org/licenses/'.
+
+;;; Code:
+
+(require 'ert)
+(require 'tramp-archive)
+
+(defconst tramp-archive-test-resource-directory
+ (let ((default-directory
+ (if load-in-progress
+ (file-name-directory load-file-name)
+ default-directory)))
+ (cond
+ ((file-accessible-directory-p (expand-file-name "resources"))
+ (expand-file-name "resources"))
+ ((file-accessible-directory-p (expand-file-name
"tramp-archive-resources"))
+ (expand-file-name "tramp-archive-resources"))))
+ "The resources directory test files are located in.")
+
+(defconst tramp-archive-test-file-archive
+ (file-truename
+ (expand-file-name "foo.tar.gz" tramp-archive-test-resource-directory))
+ "The test file archive.")
+
+(defconst tramp-archive-test-archive
+ (file-name-as-directory tramp-archive-test-file-archive)
+ "The test archive.")
+
+(setq password-cache-expiry nil
+ tramp-verbose 0
+ tramp-cache-read-persistent-data t ;; For auth-sources.
+ tramp-copy-size-limit nil
+ tramp-message-show-message nil
+ tramp-persistency-file-name nil)
+
+(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)))
+
+(defun tramp-archive--test-emacs26-p ()
+ "Check for Emacs version >= 26.1.
+Some semantics has been changed for there, w/o new functions or
+variables, so we check the Emacs version directly."
+ (>= emacs-major-version 26))
+
+(ert-deftest tramp-archive-test00-availability ()
+ "Test availability of Tramp functions."
+ :expected-result (if tramp-gvfs-enabled :passed :failed)
+ (should
+ (and
+ tramp-gvfs-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 (tramp-archive-file-name-p (concat tramp-archive-test-archive
"foo")))
+ (should
+ (tramp-archive-file-name-p (concat tramp-archive-test-archive "foo/bar")))
+ ;; A file archive inside a file archive.
+ (should
+ (tramp-archive-file-name-p (concat tramp-archive-test-archive "foo.tar")))
+ (should
+ (tramp-archive-file-name-p (concat tramp-archive-test-archive "foo.tar/"))))
+
+(ert-deftest tramp-archive-test02-file-name-dissect ()
+ "Check archive file name components."
+ (skip-unless tramp-gvfs-enabled)
+
+ (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))))
+ (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))))
+ (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 "bar.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 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
+ tramp-archive-method
+ ;; User and Domain.
+ nil nil
+ ;; 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) 0 -1)))
+ nil "/"))
+ (file-name-nondirectory tramp-archive-test-file-archive)))))
+ (should-not port)
+ (should (string-equal localname "/"))
+ (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 "/foo.tar/path/./file") "/foo.tar/path/file"))
+ (should
+ (string-equal (expand-file-name "/foo.tar/path/../file") "/foo.tar/file"))
+ ;; `expand-file-name' does not care "~/" in archive file names.
+ (should
+ (string-equal (expand-file-name "/foo.tar/~/file") "/foo.tar/~/file"))
+ ;; `expand-file-name' does not care file archive boundaries.
+ (should (string-equal (expand-file-name "/foo.tar/./file") "/foo.tar/file"))
+ (should (string-equal (expand-file-name "/foo.tar/../file") "/file")))
+
+(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'."
+ (should
+ (string-equal
+ (directory-file-name "/foo.tar/path/to/file") "/foo.tar/path/to/file"))
+ (should
+ (string-equal
+ (directory-file-name "/foo.tar/path/to/file/") "/foo.tar/path/to/file"))
+ ;; `directory-file-name' does not leave file archive boundaries.
+ (should (string-equal (directory-file-name "/foo.tar/") "/foo.tar/"))
+
+ (should
+ (string-equal
+ (file-name-as-directory "/foo.tar/path/to/file") "/foo.tar/path/to/file/"))
+ (should
+ (string-equal
+ (file-name-as-directory "/foo.tar/path/to/file/")
"/foo.tar/path/to/file/"))
+ (should (string-equal (file-name-as-directory "/foo.tar/") "/foo.tar/"))
+ (should (string-equal (file-name-as-directory "/foo.tar") "/foo.tar/"))
+
+ (should
+ (string-equal
+ (file-name-directory "/foo.tar/path/to/file") "/foo.tar/path/to/"))
+ (should
+ (string-equal
+ (file-name-directory "/foo.tar/path/to/file/") "/foo.tar/path/to/file/"))
+ (should (string-equal (file-name-directory "/foo.tar/") "/foo.tar/"))
+
+ (should
+ (string-equal (file-name-nondirectory "/foo.tar/path/to/file") "file"))
+ (should
+ (string-equal (file-name-nondirectory "/foo.tar/path/to/file/") ""))
+ (should (string-equal (file-name-nondirectory "/foo.tar/") ""))
+
+ (should-not
+ (unhandled-file-name-directory "/foo.tar/path/to/file")))
+
+(ert-deftest tramp-archive-test07-file-exists-p ()
+ "Check `file-exist-p', `write-region' and `delete-file'."
+ (skip-unless tramp-gvfs-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'."
+ (skip-unless tramp-gvfs-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 tramp-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'."
+ (skip-unless tramp-gvfs-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 tramp-file-missing))
+
+ ;; Cleanup.
+ (tramp-archive-cleanup-hash))))
+
+(ert-deftest tramp-archive-test11-copy-file ()
+ "Check `copy-file'."
+ (skip-unless tramp-gvfs-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'."
+ (skip-unless tramp-gvfs-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.
+ ;; This has been changed in Emacs 26.1.
+ (when (tramp-archive--test-emacs26-p)
+ (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'."
+ (skip-unless tramp-gvfs-enabled)
+
+ (let ((tmp-name tramp-archive-test-archive)
+ (files '("." ".." "bar" "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)
+ (delete "." (delete ".." files))))
+ (should (equal (directory-files
+ tmp-name 'full directory-files-no-dot-files-regexp)
+ (mapcar (lambda (x) (concat tmp-name x))
+ (delete "." (delete ".." files))))))
+
+ ;; Cleanup.
+ (tramp-archive-cleanup-hash))))
+
+(ert-deftest tramp-archive-test17-insert-directory ()
+ "Check `insert-directory'."
+ (skip-unless tramp-gvfs-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
+ ;; Due to Bug#29423, this works only since for Emacs 26.1.
+ (when nil ;; TODO (tramp-archive--test-emacs26-p)
+ (with-temp-buffer
+ (insert-directory tramp-archive-test-archive nil)
+ (goto-char (point-min))
+ (should
+ (looking-at-p (regexp-quote tramp-archive-test-archive)))))
+ (with-temp-buffer
+ (insert-directory tramp-archive-test-archive "-al")
+ (goto-char (point-min))
+ (should
+ (looking-at-p
+ (format "^.+ %s$" (regexp-quote tramp-archive-test-archive)))))
+ (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
+ (concat
+ ;; There might be a summary line.
+ "\\(total.+[[:digit:]]+\n\\)?"
+ ;; We don't know in which order the files appear.
+ (format
+ "\\(.+ %s\\( ->.+\\)?\n\\)\\{%d\\}"
+ (regexp-opt (directory-files tramp-archive-test-archive))
+ (length (directory-files tramp-archive-test-archive))))))))
+
+ ;; Cleanup.
+ (tramp-archive-cleanup-hash))))
+
+(ert-deftest tramp-archive-test18-file-attributes ()
+ "Check `file-attributes'.
+This tests also `file-readable-p' and `file-regular-p'."
+ (skip-unless tramp-gvfs-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))
+ attr)
+ (unwind-protect
+ (progn
+ (should (file-exists-p tmp-name1))
+ (should (file-readable-p tmp-name1))
+ (should (file-regular-p tmp-name1))
+
+ ;; 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))
+ (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)))
+
+ ;; Cleanup.
+ (tramp-archive-cleanup-hash))))
+
+(ert-deftest tramp-archive-test19-directory-files-and-attributes ()
+ "Check `directory-files-and-attributes'."
+ (skip-unless tramp-gvfs-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 "^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'."
+ (skip-unless tramp-gvfs-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'"
+ (skip-unless tramp-gvfs-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 (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
+ (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'."
+ (skip-unless tramp-gvfs-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) "bar/"))
+ (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/")))
+ (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) "bar/"))
+ (should
+ (equal
+ (sort (file-name-all-completions "" tmp-name) 'string-lessp)
+ '("bar/")))))
+
+ ;; Cleanup.
+ (tramp-archive-cleanup-hash))))
+
+;; The functions were introduced in Emacs 26.1.
+(ert-deftest tramp-archive-test37-make-nearby-temp-file ()
+ "Check `make-nearby-temp-file' and `temporary-file-directory'."
+ (skip-unless tramp-gvfs-enabled)
+ ;; Since Emacs 26.1.
+ (skip-unless
+ (and (fboundp 'make-nearby-temp-file) (fboundp 'temporary-file-directory)))
+
+ ;; `make-nearby-temp-file' and `temporary-file-directory' exists
+ ;; since Emacs 26.1. We don't want to see compiler warnings for
+ ;; older Emacsen.
+ (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 (with-no-warnings (temporary-file-directory))))
+ (should-not
+ (tramp-archive-file-name-p (with-no-warnings (temporary-file-directory))))
+
+ ;; A temporary file or directory shall not be located in the
+ ;; archive itself.
+ (setq tmp-file
+ (with-no-warnings (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
+ (with-no-warnings (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-test40-archive-file-system-info ()
+ "Check that `file-system-info' returns proper values."
+ (skip-unless tramp-gvfs-enabled)
+ ;; Since Emacs 27.1.
+ (skip-unless (fboundp 'file-system-info))
+
+ ;; `file-system-info' exists since Emacs 27. We don't want to see
+ ;; compiler warnings for older Emacsen.
+ (let ((fsi (with-no-warnings (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))))))
+
+(ert-deftest tramp-archive-test41-libarchive-tests ()
+ "Run tests of libarchive test files."
+ :tags '(:expensive-test)
+ (skip-unless tramp-gvfs-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 "uu\\'" '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]."
+ (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