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