lisp/net/tramp-archive.el

   1 ;;; tramp-archive.el --- Tramp archive manager  -*- lexical-binding:t -*-
   2
   3 ;; Copyright (C) 2017-2018 Free Software Foundation, Inc.
   4
   5 ;; Author: Michael Albinus <michael.albinus@gmx.de>
   6 ;; Keywords: comm, processes
   7 ;; Package: tramp
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; Access functions for file archives.  This is possible only on
  27 ;; machines which have installed the virtual file system for the Gnome
  28 ;; Desktop (GVFS).  Internally, file archives are mounted via the GVFS
  29 ;; "archive" method.
  30
  31 ;; A file archive is a regular file of kind "/path/to/dir/file.EXT".
  32 ;; The extension ".EXT" identifies the type of the file archive.  A
  33 ;; file inside a file archive, called archive file name, has the name
  34 ;; "/path/to/dir/file.EXT/dir/file".
  35
  36 ;; Most of the magic file name operations are implemented for archive
  37 ;; file names, exceptions are all operations which write into a file
  38 ;; archive, and process related operations.  Therefore, functions like
  39
  40 ;;   (copy-file "/path/to/dir/file.tar/dir/file" "/somewhere/else")
  41
  42 ;; work out of the box.  This is also true for file name completion,
  43 ;; and for libraries like `dired' or `ediff', which accept archive
  44 ;; file names as well.
  45
  46 ;; File archives are identified by the file name extension ".EXT".
  47 ;; Since GVFS uses internally the library libarchive(3), all suffixes,
  48 ;; which are accepted by this library, work also for archive file
  49 ;; names.  Accepted suffixes are listed in the constant
  50 ;; `tramp-archive-suffixes'.  They are
  51
  52 ;; * ".7z" - 7-Zip archives
  53 ;; * ".apk" - Android package kits
  54 ;; * ".ar" - UNIX archiver formats
  55 ;; * ".cab", ".CAB" - Microsoft Windows cabinets
  56 ;; * ".cpio" - CPIO archives
  57 ;; * ".deb" - Debian packages
  58 ;; * ".depot" - HP-UX SD depots
  59 ;; * ".exe" - Self extracting Microsoft Windows EXE files
  60 ;; * ".iso" - ISO 9660 images
  61 ;; * ".jar" - Java archives
  62 ;; * ".lzh", ".LZH" - Microsoft Windows compressed LHA archives
  63 ;; * ".msu", ".MSU" - Microsoft Windows Update packages
  64 ;; * ".mtree" - BSD mtree format
  65 ;; * ".odb" ".odf" ".odg" ".odp" ".ods" ".odt" - OpenDocument formats
  66 ;; * ".pax" - Posix archives
  67 ;; * ".rar" - RAR archives
  68 ;; * ".rpm" - Red Hat packages
  69 ;; * ".shar" - Shell archives
  70 ;; * ".tar", ".tbz", ".tgz", ".tlz", ".txz" - (Compressed) tape archives
  71 ;; * ".warc" - Web archives
  72 ;; * ".xar" - macOS XAR archives
  73 ;; * ".xpi" - XPInstall Mozilla addons
  74 ;; * ".xps" - Open XML Paper Specification (OpenXPS) documents
  75 ;; * ".zip", ".ZIP" - ZIP archives
  76
  77 ;; File archives could also be compressed, identified by an additional
  78 ;; compression suffix.  Valid compression suffixes are listed in the
  79 ;; constant `tramp-archive-compression-suffixes'.  They are ".bz2",
  80 ;; ".gz", ".lrz", ".lz", ".lz4", ".lzma", ".lzo", ".uu", ".xz" and
  81 ;; ".Z".  A valid archive file name would be
  82 ;; "/path/to/dir/file.tar.gz/dir/file".  Even several suffixes in a
  83 ;; row are possible, like "/path/to/dir/file.tar.gz.uu/dir/file".
  84
  85 ;; An archive file name could be a remote file name, as in
  86 ;; "/ftp:anonymous@ftp.gnu.org:/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL".
  87 ;; Since all file operations are mapped internally to GVFS operations,
  88 ;; remote file names supported by tramp-gvfs.el perform better,
  89 ;; because no local copy of the file archive must be downloaded first.
  90 ;; For example, "/sftp:user@host:..." performs better than the similar
  91 ;; "/scp:user@host:...".  See the constant
  92 ;; `tramp-archive-all-gvfs-methods' for a complete list of
  93 ;; tramp-gvfs.el supported method names.
  94
  95 ;; If `url-handler-mode' is enabled, archives could be visited via
  96 ;; URLs, like "https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL".
  97 ;; This allows complex file operations like
  98
  99 ;;   (ediff-directories
 100 ;;    "https://ftp.gnu.org/gnu/tramp/tramp-2.3.1.tar.gz/tramp-2.3.1"
 101 ;;    "https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/tramp-2.3.2" "")
 102
 103 ;; It is even possible to access file archives in file archives, as
 104
 105 ;;   (find-file
 106 ;;    "http://ftp.debian.org/debian/pool/main/c/coreutils/coreutils_8.28-1_amd64.deb/control.tar.gz/control")
 107
 108 ;;; Code:
 109
 110 (eval-when-compile (require 'cl-lib))
 111 (require 'tramp-gvfs)
 112
 113 (autoload 'dired-uncache "dired")
 114 (autoload 'url-tramp-convert-url-to-tramp "url-tramp")
 115 (defvar url-handler-mode-hook)
 116 (defvar url-handler-regexp)
 117 (defvar url-tramp-protocols)
 118
 119 ;; We cannot check `tramp-gvfs-enabled' in loaddefs.el, because this
 120 ;; would load Tramp.  So we make a cheaper check.
 121 ;;;###autoload
 122 (defvar tramp-archive-enabled (featurep 'dbusbind)
 123   "Non-nil when file archive support is available.")
 124
 125 ;; After loading tramp-gvfs.el, we know it better.
 126 (setq tramp-archive-enabled tramp-gvfs-enabled)
 127
 128 ;; <https://github.com/libarchive/libarchive/wiki/LibarchiveFormats>
 129 ;;;###autoload
 130 (defconst tramp-archive-suffixes
 131   ;; "cab", "lzh", "msu" and "zip" are included with lower and upper
 132   ;; letters, because Microsoft Windows provides them often with
 133   ;; capital letters.
 134   '("7z" ;; 7-Zip archives.
 135     "apk" ;; Android package kits.  Not in libarchive testsuite.
 136     "ar" ;; UNIX archiver formats.
 137     "cab" "CAB" ;; Microsoft Windows cabinets.
 138     "cpio" ;; CPIO archives.
 139     "deb" ;; Debian packages.  Not in libarchive testsuite.
 140     "depot" ;; HP-UX SD depot.  Not in libarchive testsuite.
 141     "exe" ;; Self extracting Microsoft Windows EXE files.
 142     "iso" ;; ISO 9660 images.
 143     "jar" ;; Java archives.  Not in libarchive testsuite.
 144     "lzh" "LZH" ;; Microsoft Windows compressed LHA archives.
 145     "msu" "MSU" ;; Microsoft Windows Update packages.  Not in testsuite.
 146     "mtree" ;; BSD mtree format.
 147     "odb" "odf" "odg" "odp" "ods" "odt" ;; OpenDocument formats.  Not in testsuite.
 148     "pax" ;; Posix archives.
 149     "rar" ;; RAR archives.
 150     "rpm" ;; Red Hat packages.
 151     "shar" ;; Shell archives.  Not in libarchive testsuite.
 152     "tar" "tbz" "tgz" "tlz" "txz" ;; (Compressed) tape archives.
 153     "warc" ;; Web archives.
 154     "xar" ;; macOS XAR archives.  Not in libarchive testsuite.
 155     "xpi" ;; XPInstall Mozilla addons.  Not in libarchive testsuite.
 156     "xps" ;; Open XML Paper Specification (OpenXPS) documents.
 157     "zip" "ZIP") ;; ZIP archives.
 158   "List of suffixes which indicate a file archive.
 159 It must be supported by libarchive(3).")
 160
 161 ;; <http://unix-memo.readthedocs.io/en/latest/vfs.html>
 162 ;;    read and write: tar, cpio, pax , gzip , zip, bzip2, xz, lzip, lzma, ar, mtree, iso9660, compress.
 163 ;;    read only: 7-Zip, mtree, xar, lha/lzh, rar, microsoft cab.
 164
 165 ;;;###autoload
 166 (defconst tramp-archive-compression-suffixes
 167   '("bz2" "gz" "lrz" "lz" "lz4" "lzma" "lzo" "uu" "xz" "Z")
 168   "List of suffixes which indicate a compressed file.
 169 It must be supported by libarchive(3).")
 170
 171 ;; The definition of `tramp-archive-file-name-regexp' contains calls
 172 ;; to `regexp-opt', which cannot be autoloaded while loading
 173 ;; loaddefs.el.  So we use a macro, which is evaluated only when needed.
 174 ;;;###autoload
 175 (progn (defmacro tramp-archive-autoload-file-name-regexp ()
 176   "Regular expression matching archive file names."
 177   `(concat
 178     "\\`" "\\(" ".+" "\\."
 179       ;; Default suffixes ...
 180       (regexp-opt tramp-archive-suffixes)
 181       ;; ... with compression.
 182       "\\(?:" "\\." (regexp-opt tramp-archive-compression-suffixes) "\\)*"
 183     "\\)" ;; \1
 184     "\\(" "/" ".*" "\\)" "\\'"))) ;; \2
 185
 186 ;; In older Emacsen (prior 27.1), `tramp-archive-autoload-file-name-regexp'
 187 ;; is not autoloaded.  So we cannot expect it to be known in
 188 ;; tramp-loaddefs.el. But it exists, when tramp-archive.el is loaded.
 189 ;;;###tramp-autoload
 190 (defconst tramp-archive-file-name-regexp
 191   (ignore-errors (tramp-archive-autoload-file-name-regexp))
 192   "Regular expression matching archive file names.")
 193
 194 ;;;###tramp-autoload
 195 (defconst tramp-archive-method "archive"
 196   "Method name for archives in GVFS.")
 197
 198 (defconst tramp-archive-all-gvfs-methods
 199   (cons tramp-archive-method
 200         (let ((values (cdr (cadr (get 'tramp-gvfs-methods 'custom-type)))))
 201           (setq values (mapcar 'last values)
 202                 values (mapcar 'car values))))
 203   "List of all methods `tramp-gvfs-methods' offers.")
 204
 205 \f
 206 ;; New handlers should be added here.
 207 ;;;###tramp-autoload
 208 (defconst tramp-archive-file-name-handler-alist
 209   '((access-file . ignore)
 210     (add-name-to-file . tramp-archive-handle-not-implemented)
 211     ;; `byte-compiler-base-file-name' performed by default handler.
 212     ;; `copy-directory' performed by default handler.
 213     (copy-file . tramp-archive-handle-copy-file)
 214     (delete-directory . tramp-archive-handle-not-implemented)
 215     (delete-file . tramp-archive-handle-not-implemented)
 216     ;; `diff-latest-backup-file' performed by default handler.
 217     (directory-file-name . tramp-archive-handle-directory-file-name)
 218     (directory-files . tramp-handle-directory-files)
 219     (directory-files-and-attributes
 220      . tramp-handle-directory-files-and-attributes)
 221     (dired-compress-file . tramp-archive-handle-not-implemented)
 222     (dired-uncache . tramp-archive-handle-dired-uncache)
 223     ;; `expand-file-name' performed by default handler.
 224     (file-accessible-directory-p . tramp-handle-file-accessible-directory-p)
 225     (file-acl . ignore)
 226     (file-attributes . tramp-archive-handle-file-attributes)
 227     (file-directory-p . tramp-handle-file-directory-p)
 228     (file-equal-p . tramp-handle-file-equal-p)
 229     (file-executable-p . tramp-archive-handle-file-executable-p)
 230     (file-exists-p . tramp-handle-file-exists-p)
 231     (file-in-directory-p . tramp-handle-file-in-directory-p)
 232     (file-local-copy . tramp-archive-handle-file-local-copy)
 233     (file-modes . tramp-handle-file-modes)
 234     (file-name-all-completions . tramp-archive-handle-file-name-all-completions)
 235     ;; `file-name-as-directory' performed by default handler.
 236     (file-name-case-insensitive-p . ignore)
 237     (file-name-completion . tramp-handle-file-name-completion)
 238     ;; `file-name-directory' performed by default handler.
 239     ;; `file-name-nondirectory' performed by default handler.
 240     ;; `file-name-sans-versions' performed by default handler.
 241     (file-newer-than-file-p . tramp-handle-file-newer-than-file-p)
 242     (file-notify-add-watch . ignore)
 243     (file-notify-rm-watch . ignore)
 244     (file-notify-valid-p . ignore)
 245     (file-ownership-preserved-p . ignore)
 246     (file-readable-p . tramp-archive-handle-file-readable-p)
 247     (file-regular-p . tramp-handle-file-regular-p)
 248     ;; `file-remote-p' performed by default handler.
 249     (file-selinux-context . tramp-handle-file-selinux-context)
 250     (file-symlink-p . tramp-handle-file-symlink-p)
 251     (file-system-info . tramp-archive-handle-file-system-info)
 252     (file-truename . tramp-archive-handle-file-truename)
 253     (file-writable-p . ignore)
 254     (find-backup-file-name . ignore)
 255     ;; `find-file-noselect' performed by default handler.
 256     ;; `get-file-buffer' performed by default handler.
 257     (insert-directory . tramp-archive-handle-insert-directory)
 258     (insert-file-contents . tramp-archive-handle-insert-file-contents)
 259     (load . tramp-archive-handle-load)
 260     (make-auto-save-file-name . ignore)
 261     (make-directory . tramp-archive-handle-not-implemented)
 262     (make-directory-internal . tramp-archive-handle-not-implemented)
 263     (make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
 264     (make-symbolic-link . tramp-archive-handle-not-implemented)
 265     (process-file . ignore)
 266     (rename-file . tramp-archive-handle-not-implemented)
 267     (set-file-acl . ignore)
 268     (set-file-modes . tramp-archive-handle-not-implemented)
 269     (set-file-selinux-context . ignore)
 270     (set-file-times . tramp-archive-handle-not-implemented)
 271     (set-visited-file-modtime . tramp-handle-set-visited-file-modtime)
 272     (shell-command . tramp-archive-handle-not-implemented)
 273     (start-file-process . tramp-archive-handle-not-implemented)
 274     ;; `substitute-in-file-name' performed by default handler.
 275     (temporary-file-directory . tramp-archive-handle-temporary-file-directory)
 276     (unhandled-file-name-directory . ignore)
 277     (vc-registered . ignore)
 278     (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
 279     (write-region . tramp-archive-handle-not-implemented))
 280   "Alist of handler functions for file archive method.
 281 Operations not mentioned here will be handled by the default Emacs primitives.")
 282
 283 (defsubst tramp-archive-file-name-for-operation (operation &rest args)
 284   "Like `tramp-file-name-for-operation', but for archive file name syntax."
 285   (cl-letf (((symbol-function 'tramp-tramp-file-p) 'tramp-archive-file-name-p))
 286     (apply 'tramp-file-name-for-operation operation args)))
 287
 288 (defun tramp-archive-run-real-handler (operation args)
 289   "Invoke normal file name handler for OPERATION.
 290 First arg specifies the OPERATION, second arg is a list of arguments to
 291 pass to the OPERATION."
 292   (let* ((inhibit-file-name-handlers
 293           `(tramp-archive-file-name-handler
 294             .
 295             ,(and (eq inhibit-file-name-operation operation)
 296                   inhibit-file-name-handlers)))
 297          (inhibit-file-name-operation operation))
 298     (apply operation args)))
 299
 300 ;;;###tramp-autoload
 301 (defun tramp-archive-file-name-handler (operation &rest args)
 302   "Invoke the file archive related OPERATION.
 303 First arg specifies the OPERATION, second arg is a list of arguments to
 304 pass to the OPERATION."
 305     (if (not tramp-archive-enabled)
 306         ;; Unregister `tramp-archive-file-name-handler'.
 307         (progn
 308           (tramp-register-file-name-handlers)
 309           (tramp-archive-run-real-handler operation args))
 310
 311       (let* ((filename (apply 'tramp-archive-file-name-for-operation
 312                               operation args))
 313              (archive (tramp-archive-file-name-archive filename)))
 314
 315         ;; The file archive could be a directory, see Bug#30293.
 316         (if (and archive
 317                  (tramp-archive-run-real-handler
 318                   'file-directory-p (list archive)))
 319             (tramp-archive-run-real-handler operation args)
 320           ;; Now run the handler.
 321           (let ((tramp-methods (cons `(,tramp-archive-method) tramp-methods))
 322                 (tramp-gvfs-methods tramp-archive-all-gvfs-methods)
 323                 ;; Set uid and gid.  gvfsd-archive could do it, but it doesn't.
 324                 (tramp-unknown-id-integer (user-uid))
 325                 (tramp-unknown-id-string (user-login-name))
 326                 (fn (assoc operation tramp-archive-file-name-handler-alist)))
 327             (when (eq (cdr fn) 'tramp-archive-handle-not-implemented)
 328               (setq args (cons operation args)))
 329             (if fn
 330                 (save-match-data (apply (cdr fn) args))
 331               (tramp-archive-run-real-handler operation args)))))))
 332
 333 ;;;###autoload
 334 (progn (defun tramp-register-archive-file-name-handler ()
 335   "Add archive file name handler to `file-name-handler-alist'."
 336   (when tramp-archive-enabled
 337     (add-to-list 'file-name-handler-alist
 338                  (cons (tramp-archive-autoload-file-name-regexp)
 339                        'tramp-autoload-file-name-handler))
 340     (put 'tramp-archive-file-name-handler 'safe-magic t))))
 341
 342 ;;;###autoload
 343 (progn
 344   (add-hook 'after-init-hook 'tramp-register-archive-file-name-handler)
 345   (add-hook
 346    'tramp-archive-unload-hook
 347    (lambda ()
 348      (remove-hook
 349       'after-init-hook 'tramp-register-archive-file-name-handler))))
 350
 351 ;; In older Emacsen (prior 27.1), the autoload above does not exist.
 352 ;; So we call it again; it doesn't hurt.
 353 (tramp-register-archive-file-name-handler)
 354
 355 ;; Mark `operations' the handler is responsible for.
 356 (put 'tramp-archive-file-name-handler 'operations
 357      (mapcar 'car tramp-archive-file-name-handler-alist))
 358
 359 ;; `tramp-archive-file-name-handler' must be placed before `url-file-handler'.
 360 (when url-handler-mode (tramp-register-file-name-handlers))
 361
 362 (eval-after-load 'url-handler
 363   (progn
 364     (add-hook 'url-handler-mode-hook 'tramp-register-file-name-handlers)
 365     (add-hook
 366      'tramp-archive-unload-hook
 367      (lambda ()
 368        (remove-hook
 369         'url-handler-mode-hook 'tramp-register-file-name-handlers)))))
 370
 371 \f
 372 ;; File name conversions.
 373
 374 (defun tramp-archive-file-name-p (name)
 375   "Return t if NAME is a string with archive file name syntax."
 376   (and (stringp name)
 377        (string-match tramp-archive-file-name-regexp name)
 378        t))
 379
 380 (defun tramp-archive-file-name-archive (name)
 381   "Return archive part of NAME."
 382   (and (tramp-archive-file-name-p name)
 383        (match-string 1 name)))
 384
 385 (defun tramp-archive-file-name-localname (name)
 386   "Return localname part of NAME."
 387   (and (tramp-archive-file-name-p name)
 388        (match-string 2 name)))
 389
 390 (defvar tramp-archive-hash (make-hash-table :test 'equal)
 391   "Hash table for archive local copies.
 392 The hash key is the archive name.  The value is a cons of the
 393 used `tramp-file-name' structure for tramp-gvfs, and the file
 394 name of a local copy, if any.")
 395
 396 (defsubst tramp-archive-gvfs-host (archive)
 397   "Return host name of ARCHIVE as used in GVFS for mounting"
 398   (url-hexify-string (tramp-gvfs-url-file-name archive)))
 399
 400 (defun tramp-archive-dissect-file-name (name)
 401   "Return a `tramp-file-name' structure.
 402 The structure consists of the `tramp-archive-method' method, the
 403 hexified archive name as host, and the localname.  The archive
 404 name is kept in slot `hop'"
 405   (save-match-data
 406     (unless (tramp-archive-file-name-p name)
 407       (tramp-user-error nil "Not an archive file name: \"%s\"" name))
 408     (let* ((localname (tramp-archive-file-name-localname name))
 409            (archive (file-truename (tramp-archive-file-name-archive name)))
 410            (vec (make-tramp-file-name
 411                  :method tramp-archive-method :hop archive)))
 412
 413       (cond
 414        ;; The value is already in the hash table.
 415        ((gethash archive tramp-archive-hash)
 416         (setq vec (car (gethash archive tramp-archive-hash))))
 417
 418        ;; File archives inside file archives.
 419        ((tramp-archive-file-name-p archive)
 420         (let ((archive
 421                (tramp-make-tramp-file-name
 422                 (tramp-archive-dissect-file-name archive) nil 'noarchive)))
 423           (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive)))
 424         (puthash archive (list vec) tramp-archive-hash))
 425
 426        ;; http://...
 427        ((and url-handler-mode
 428              tramp-compat-use-url-tramp-p
 429              (string-match url-handler-regexp archive)
 430              (string-match "https?" (url-type (url-generic-parse-url archive))))
 431         (let* ((url-tramp-protocols
 432                 (cons
 433                  (url-type (url-generic-parse-url archive))
 434                  url-tramp-protocols))
 435                (archive (url-tramp-convert-url-to-tramp archive)))
 436           (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive)))
 437         (puthash archive (list vec) tramp-archive-hash))
 438
 439        ;; GVFS supported schemes.
 440        ((or (tramp-gvfs-file-name-p archive)
 441             (not (file-remote-p archive)))
 442         (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive))
 443         (puthash archive (list vec) tramp-archive-hash))
 444
 445        ;; Anything else.  Here we call `file-local-copy', which we
 446        ;; have avoided so far.
 447        (t (let* ((inhibit-file-name-operation 'file-local-copy)
 448                  (inhibit-file-name-handlers
 449                   (cons 'jka-compr-handler inhibit-file-name-handlers))
 450                  (copy (file-local-copy archive)))
 451             (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host copy))
 452             (puthash archive (cons vec copy) tramp-archive-hash))))
 453
 454       ;; So far, `vec' handles just the mount point.  Add `localname',
 455       ;; which shouldn't be pushed to the hash.
 456       (setf (tramp-file-name-localname vec) localname)
 457       vec)))
 458
 459 ;;;###tramp-autoload
 460 (defun tramp-archive-cleanup-hash ()
 461   "Remove local copies of archives, used by GVFS."
 462   (maphash
 463    (lambda (key value)
 464      ;; Unmount local copy.
 465      (ignore-errors
 466        (tramp-message (car value) 3 "Unmounting %s" (or (cdr value) key))
 467        (tramp-gvfs-unmount (car value)))
 468      ;; Delete local copy.
 469      (ignore-errors (delete-file (cdr value)))
 470      (remhash key tramp-archive-hash))
 471    tramp-archive-hash)
 472   (clrhash tramp-archive-hash))
 473
 474 (add-hook 'kill-emacs-hook 'tramp-archive-cleanup-hash)
 475 (add-hook 'tramp-archive-unload-hook
 476           (lambda ()
 477             (remove-hook 'kill-emacs-hook
 478                          'tramp-archive-cleanup-hash)))
 479
 480 (defsubst tramp-file-name-archive (vec)
 481   "Extract the archive file name from VEC.
 482 VEC is expected to be a `tramp-file-name', with the method being
 483 `tramp-archive-method', and the host being a coded URL.  The
 484 archive name is extracted from the hop part of the VEC structure."
 485   (and (tramp-file-name-p vec)
 486        (string-equal (tramp-file-name-method vec) tramp-archive-method)
 487        (tramp-file-name-hop vec)))
 488
 489 (defmacro with-parsed-tramp-archive-file-name (filename var &rest body)
 490   "Parse an archive filename and make components available in the body.
 491 This works exactly as `with-parsed-tramp-file-name' for the Tramp
 492 file name structure returned by `tramp-archive-dissect-file-name'.
 493 A variable `foo-archive' (or `archive') will be bound to the
 494 archive name part of FILENAME, assuming `foo' (or nil) is the
 495 value of VAR.  OTOH, the variable `foo-hop' (or `hop') won't be
 496 offered."
 497   (declare (debug (form symbolp body))
 498            (indent 2))
 499   (let ((bindings
 500          (mapcar (lambda (elem)
 501                    `(,(if var (intern (format "%s-%s" var elem)) elem)
 502                      (,(intern (format "tramp-file-name-%s" elem))
 503                       ,(or var 'v))))
 504                  `,(cons
 505                     'archive
 506                     (delete 'hop (tramp-compat-tramp-file-name-slots))))))
 507     `(let* ((,(or var 'v) (tramp-archive-dissect-file-name ,filename))
 508             ,@bindings)
 509        ;; We don't know which of those vars will be used, so we bind them all,
 510        ;; and then add here a dummy use of all those variables, so we don't get
 511        ;; flooded by warnings about those vars `body' didn't use.
 512        (ignore ,@(mapcar #'car bindings))
 513        ,@body)))
 514
 515 (defun tramp-archive-gvfs-file-name (name)
 516   "Return FILENAME in GVFS syntax."
 517   (tramp-make-tramp-file-name
 518    (tramp-archive-dissect-file-name name) nil 'nohop))
 519
 520 \f
 521 ;; File name primitives.
 522
 523 (defun tramp-archive-handle-copy-file
 524   (filename newname &optional ok-if-already-exists keep-date
 525    preserve-uid-gid preserve-extended-attributes)
 526   "Like `copy-file' for file archives."
 527   (when (tramp-archive-file-name-p newname)
 528     (tramp-error
 529      (tramp-archive-dissect-file-name newname) 'file-error
 530       "Permission denied: %s" newname))
 531   (copy-file
 532    (tramp-archive-gvfs-file-name filename) newname ok-if-already-exists
 533    keep-date preserve-uid-gid preserve-extended-attributes))
 534
 535 (defun tramp-archive-handle-directory-file-name (directory)
 536   "Like `directory-file-name' for file archives."
 537   (with-parsed-tramp-archive-file-name directory nil
 538     (if (and (not (zerop (length localname)))
 539              (eq (aref localname (1- (length localname))) ?/)
 540              (not (string= localname "/")))
 541         (substring directory 0 -1)
 542       ;; We do not want to leave the file archive.  This would require
 543       ;; unnecessary download of http-based file archives, for
 544       ;; example.  So we return `directory'.
 545       directory)))
 546
 547 (defun tramp-archive-handle-dired-uncache (dir)
 548   "Like `dired-uncache' for file archives."
 549   (dired-uncache (tramp-archive-gvfs-file-name dir)))
 550
 551 (defun tramp-archive-handle-file-attributes (filename &optional id-format)
 552   "Like `file-attributes' for file archives."
 553   (file-attributes (tramp-archive-gvfs-file-name filename) id-format))
 554
 555 (defun tramp-archive-handle-file-executable-p (filename)
 556   "Like `file-executable-p' for file archives."
 557   (file-executable-p (tramp-archive-gvfs-file-name filename)))
 558
 559 (defun tramp-archive-handle-file-local-copy (filename)
 560   "Like `file-local-copy' for file archives."
 561   (file-local-copy (tramp-archive-gvfs-file-name filename)))
 562
 563 (defun tramp-archive-handle-file-name-all-completions (filename directory)
 564   "Like `file-name-all-completions' for file archives."
 565   (file-name-all-completions filename (tramp-archive-gvfs-file-name directory)))
 566
 567 (defun tramp-archive-handle-file-readable-p (filename)
 568   "Like `file-readable-p' for file archives."
 569   (with-parsed-tramp-file-name
 570       (tramp-archive-gvfs-file-name filename) nil
 571     (tramp-check-cached-permissions v ?r)))
 572
 573 (defun tramp-archive-handle-file-system-info (filename)
 574   "Like `file-system-info' for file archives."
 575   (with-parsed-tramp-archive-file-name filename nil
 576     (list (tramp-compat-file-attribute-size (file-attributes archive)) 0 0)))
 577
 578 (defun tramp-archive-handle-file-truename (filename)
 579   "Like `file-truename' for file archives."
 580   (with-parsed-tramp-archive-file-name filename nil
 581     (let ((local (or (file-symlink-p filename) localname)))
 582       (unless (file-name-absolute-p local)
 583         (setq local (expand-file-name local (file-name-directory localname))))
 584       (concat (file-truename archive) local))))
 585
 586 (defun tramp-archive-handle-insert-directory
 587   (filename switches &optional wildcard full-directory-p)
 588   "Like `insert-directory' for file archives."
 589   (insert-directory
 590    (tramp-archive-gvfs-file-name filename) switches wildcard full-directory-p)
 591   (goto-char (point-min))
 592   (while (search-forward (tramp-archive-gvfs-file-name filename) nil 'noerror)
 593     (replace-match filename)))
 594
 595 (defun tramp-archive-handle-insert-file-contents
 596   (filename &optional visit beg end replace)
 597   "Like `insert-file-contents' for file archives."
 598   (let ((result
 599          (insert-file-contents
 600           (tramp-archive-gvfs-file-name filename) visit beg end replace)))
 601     (prog1
 602         (list (expand-file-name filename)
 603               (cadr result))
 604       (when visit (setq buffer-file-name filename)))))
 605
 606 (defun tramp-archive-handle-load
 607     (file &optional noerror nomessage nosuffix must-suffix)
 608   "Like `load' for file archives."
 609   (load
 610    (tramp-archive-gvfs-file-name file) noerror nomessage nosuffix must-suffix))
 611
 612 (defun tramp-archive-handle-temporary-file-directory ()
 613   "Like `temporary-file-directory' for file archives."
 614   ;; If the default directory, the file archive, is located on a
 615   ;; mounted directory, it is returned as it.  Not what we want.
 616   (with-parsed-tramp-archive-file-name default-directory nil
 617     (let ((default-directory (file-name-directory archive)))
 618       (tramp-compat-temporary-file-directory))))
 619
 620 (defun tramp-archive-handle-not-implemented (operation &rest args)
 621   "Generic handler for operations not implemented for file archives."
 622   (let ((v (ignore-errors
 623              (tramp-archive-dissect-file-name
 624               (apply 'tramp-archive-file-name-for-operation operation args)))))
 625     (tramp-message v 10 "%s" (cons operation args))
 626     (tramp-error
 627      v 'file-error
 628      "Operation `%s' not implemented for file archives" operation)))
 629
 630 (add-hook 'tramp-unload-hook
 631           (lambda ()
 632             (unload-feature 'tramp-archive 'force)))
 633
 634 (provide 'tramp-archive)
 635
 636 ;;; TODO:
 637
 638 ;; * Check, whether we could retrieve better file attributes like uid,
 639 ;;   gid, permissions.  See gvfsbackendarchive.c
 640 ;;   (archive_file_set_info_from_entry), where it is commented out.
 641 ;;
 642 ;; * Implement write access, when possible.
 643 ;;   https://bugzilla.gnome.org/show_bug.cgi?id=589617
 644
 645 ;;; tramp-archive.el ends here