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   (let* ((filename (apply 'tramp-archive-file-name-for-operation
 306                           operation args))
 307          (archive (tramp-archive-file-name-archive filename)))
 308     ;; The file archive could be a directory, see Bug#30293.
 309     (if (and archive
 310              (tramp-archive-run-real-handler 'file-directory-p (list archive)))
 311         (tramp-archive-run-real-handler operation args)
 312       ;; Now run the handler.
 313       (unless tramp-archive-enabled
 314         (tramp-user-error nil "Package `tramp-archive' not supported"))
 315       (let ((tramp-methods (cons `(,tramp-archive-method) tramp-methods))
 316             (tramp-gvfs-methods tramp-archive-all-gvfs-methods)
 317             ;; Set uid and gid.  gvfsd-archive could do it, but it doesn't.
 318             (tramp-unknown-id-integer (user-uid))
 319             (tramp-unknown-id-string (user-login-name))
 320             (fn (assoc operation tramp-archive-file-name-handler-alist)))
 321         (when (eq (cdr fn) 'tramp-archive-handle-not-implemented)
 322           (setq args (cons operation args)))
 323         (if fn
 324             (save-match-data (apply (cdr fn) args))
 325           (tramp-archive-run-real-handler operation args))))))
 326
 327 ;;;###autoload
 328 (progn (defun tramp-register-archive-file-name-handler ()
 329   "Add archive file name handler to `file-name-handler-alist'."
 330   (when tramp-archive-enabled
 331     (add-to-list 'file-name-handler-alist
 332                  (cons (tramp-archive-autoload-file-name-regexp)
 333                        'tramp-autoload-file-name-handler))
 334     (put 'tramp-archive-file-name-handler 'safe-magic t))))
 335
 336 ;;;###autoload
 337 (progn
 338   (add-hook 'after-init-hook 'tramp-register-archive-file-name-handler)
 339   (add-hook
 340    'tramp-archive-unload-hook
 341    (lambda ()
 342      (remove-hook
 343       'after-init-hook 'tramp-register-archive-file-name-handler))))
 344
 345 ;; In older Emacsen (prior 27.1), the autoload above does not exist.
 346 ;; So we call it again; it doesn't hurt.
 347 (tramp-register-archive-file-name-handler)
 348
 349 ;; Mark `operations' the handler is responsible for.
 350 (put 'tramp-archive-file-name-handler 'operations
 351      (mapcar 'car tramp-archive-file-name-handler-alist))
 352
 353 ;; `tramp-archive-file-name-handler' must be placed before `url-file-handler'.
 354 (when url-handler-mode (tramp-register-file-name-handlers))
 355
 356 (eval-after-load 'url-handler
 357   (progn
 358     (add-hook 'url-handler-mode-hook 'tramp-register-file-name-handlers)
 359     (add-hook
 360      'tramp-archive-unload-hook
 361      (lambda ()
 362        (remove-hook
 363         'url-handler-mode-hook 'tramp-register-file-name-handlers)))))
 364
 365 \f
 366 ;; File name conversions.
 367
 368 (defun tramp-archive-file-name-p (name)
 369   "Return t if NAME is a string with archive file name syntax."
 370   (and (stringp name)
 371        (string-match tramp-archive-file-name-regexp name)
 372        t))
 373
 374 (defun tramp-archive-file-name-archive (name)
 375   "Return archive part of NAME."
 376   (and (tramp-archive-file-name-p name)
 377        (match-string 1 name)))
 378
 379 (defun tramp-archive-file-name-localname (name)
 380   "Return localname part of NAME."
 381   (and (tramp-archive-file-name-p name)
 382        (match-string 2 name)))
 383
 384 (defvar tramp-archive-hash (make-hash-table :test 'equal)
 385   "Hash table for archive local copies.
 386 The hash key is the archive name.  The value is a cons of the
 387 used `tramp-file-name' structure for tramp-gvfs, and the file
 388 name of a local copy, if any.")
 389
 390 (defsubst tramp-archive-gvfs-host (archive)
 391   "Return host name of ARCHIVE as used in GVFS for mounting"
 392   (url-hexify-string (tramp-gvfs-url-file-name archive)))
 393
 394 (defun tramp-archive-dissect-file-name (name)
 395   "Return a `tramp-file-name' structure.
 396 The structure consists of the `tramp-archive-method' method, the
 397 hexified archive name as host, and the localname.  The archive
 398 name is kept in slot `hop'"
 399   (save-match-data
 400     (unless (tramp-archive-file-name-p name)
 401       (tramp-user-error nil "Not an archive file name: \"%s\"" name))
 402     (let* ((localname (tramp-archive-file-name-localname name))
 403            (archive (file-truename (tramp-archive-file-name-archive name)))
 404            (vec (make-tramp-file-name
 405                  :method tramp-archive-method :hop archive)))
 406
 407       (cond
 408        ;; The value is already in the hash table.
 409        ((gethash archive tramp-archive-hash)
 410         (setq vec (car (gethash archive tramp-archive-hash))))
 411
 412        ;; File archives inside file archives.
 413        ((tramp-archive-file-name-p archive)
 414         (let ((archive
 415                (tramp-make-tramp-file-name
 416                 (tramp-archive-dissect-file-name archive) nil 'noarchive)))
 417           (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive)))
 418         (puthash archive (list vec) tramp-archive-hash))
 419
 420        ;; http://...
 421        ((and url-handler-mode
 422              tramp-compat-use-url-tramp-p
 423              (string-match url-handler-regexp archive)
 424              (string-match "https?" (url-type (url-generic-parse-url archive))))
 425         (let* ((url-tramp-protocols
 426                 (cons
 427                  (url-type (url-generic-parse-url archive))
 428                  url-tramp-protocols))
 429                (archive (url-tramp-convert-url-to-tramp archive)))
 430           (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive)))
 431         (puthash archive (list vec) tramp-archive-hash))
 432
 433        ;; GVFS supported schemes.
 434        ((or (tramp-gvfs-file-name-p archive)
 435             (not (file-remote-p archive)))
 436         (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive))
 437         (puthash archive (list vec) tramp-archive-hash))
 438
 439        ;; Anything else.  Here we call `file-local-copy', which we
 440        ;; have avoided so far.
 441        (t (let* ((inhibit-file-name-operation 'file-local-copy)
 442                  (inhibit-file-name-handlers
 443                   (cons 'jka-compr-handler inhibit-file-name-handlers))
 444                  (copy (file-local-copy archive)))
 445             (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host copy))
 446             (puthash archive (cons vec copy) tramp-archive-hash))))
 447
 448       ;; So far, `vec' handles just the mount point.  Add `localname',
 449       ;; which shouldn't be pushed to the hash.
 450       (setf (tramp-file-name-localname vec) localname)
 451       vec)))
 452
 453 ;;;###tramp-autoload
 454 (defun tramp-archive-cleanup-hash ()
 455   "Remove local copies of archives, used by GVFS."
 456   (maphash
 457    (lambda (key value)
 458      ;; Unmount local copy.
 459      (ignore-errors
 460        (tramp-message (car value) 3 "Unmounting %s" (or (cdr value) key))
 461        (tramp-gvfs-unmount (car value)))
 462      ;; Delete local copy.
 463      (ignore-errors (delete-file (cdr value)))
 464      (remhash key tramp-archive-hash))
 465    tramp-archive-hash)
 466   (clrhash tramp-archive-hash))
 467
 468 (add-hook 'kill-emacs-hook 'tramp-archive-cleanup-hash)
 469 (add-hook 'tramp-archive-unload-hook
 470           (lambda ()
 471             (remove-hook 'kill-emacs-hook
 472                          'tramp-archive-cleanup-hash)))
 473
 474 (defsubst tramp-file-name-archive (vec)
 475   "Extract the archive file name from VEC.
 476 VEC is expected to be a `tramp-file-name', with the method being
 477 `tramp-archive-method', and the host being a coded URL.  The
 478 archive name is extracted from the hop part of the VEC structure."
 479   (and (tramp-file-name-p vec)
 480        (string-equal (tramp-file-name-method vec) tramp-archive-method)
 481        (tramp-file-name-hop vec)))
 482
 483 (defmacro with-parsed-tramp-archive-file-name (filename var &rest body)
 484   "Parse an archive filename and make components available in the body.
 485 This works exactly as `with-parsed-tramp-file-name' for the Tramp
 486 file name structure returned by `tramp-archive-dissect-file-name'.
 487 A variable `foo-archive' (or `archive') will be bound to the
 488 archive name part of FILENAME, assuming `foo' (or nil) is the
 489 value of VAR.  OTOH, the variable `foo-hop' (or `hop') won't be
 490 offered."
 491   (declare (debug (form symbolp body))
 492            (indent 2))
 493   (let ((bindings
 494          (mapcar (lambda (elem)
 495                    `(,(if var (intern (format "%s-%s" var elem)) elem)
 496                      (,(intern (format "tramp-file-name-%s" elem))
 497                       ,(or var 'v))))
 498                  `,(cons
 499                     'archive
 500                     (delete 'hop (tramp-compat-tramp-file-name-slots))))))
 501     `(let* ((,(or var 'v) (tramp-archive-dissect-file-name ,filename))
 502             ,@bindings)
 503        ;; We don't know which of those vars will be used, so we bind them all,
 504        ;; and then add here a dummy use of all those variables, so we don't get
 505        ;; flooded by warnings about those vars `body' didn't use.
 506        (ignore ,@(mapcar #'car bindings))
 507        ,@body)))
 508
 509 (defun tramp-archive-gvfs-file-name (name)
 510   "Return FILENAME in GVFS syntax."
 511   (tramp-make-tramp-file-name
 512    (tramp-archive-dissect-file-name name) nil 'nohop))
 513
 514 \f
 515 ;; File name primitives.
 516
 517 (defun tramp-archive-handle-copy-file
 518   (filename newname &optional ok-if-already-exists keep-date
 519    preserve-uid-gid preserve-extended-attributes)
 520   "Like `copy-file' for file archives."
 521   (when (tramp-archive-file-name-p newname)
 522     (tramp-error
 523      (tramp-archive-dissect-file-name newname) 'file-error
 524       "Permission denied: %s" newname))
 525   (copy-file
 526    (tramp-archive-gvfs-file-name filename) newname ok-if-already-exists
 527    keep-date preserve-uid-gid preserve-extended-attributes))
 528
 529 (defun tramp-archive-handle-directory-file-name (directory)
 530   "Like `directory-file-name' for file archives."
 531   (with-parsed-tramp-archive-file-name directory nil
 532     (if (and (not (zerop (length localname)))
 533              (eq (aref localname (1- (length localname))) ?/)
 534              (not (string= localname "/")))
 535         (substring directory 0 -1)
 536       ;; We do not want to leave the file archive.  This would require
 537       ;; unnecessary download of http-based file archives, for
 538       ;; example.  So we return `directory'.
 539       directory)))
 540
 541 (defun tramp-archive-handle-dired-uncache (dir)
 542   "Like `dired-uncache' for file archives."
 543   (dired-uncache (tramp-archive-gvfs-file-name dir)))
 544
 545 (defun tramp-archive-handle-file-attributes (filename &optional id-format)
 546   "Like `file-attributes' for file archives."
 547   (file-attributes (tramp-archive-gvfs-file-name filename) id-format))
 548
 549 (defun tramp-archive-handle-file-executable-p (filename)
 550   "Like `file-executable-p' for file archives."
 551   (file-executable-p (tramp-archive-gvfs-file-name filename)))
 552
 553 (defun tramp-archive-handle-file-local-copy (filename)
 554   "Like `file-local-copy' for file archives."
 555   (file-local-copy (tramp-archive-gvfs-file-name filename)))
 556
 557 (defun tramp-archive-handle-file-name-all-completions (filename directory)
 558   "Like `file-name-all-completions' for file archives."
 559   (file-name-all-completions filename (tramp-archive-gvfs-file-name directory)))
 560
 561 (defun tramp-archive-handle-file-readable-p (filename)
 562   "Like `file-readable-p' for file archives."
 563   (with-parsed-tramp-file-name
 564       (tramp-archive-gvfs-file-name filename) nil
 565     (tramp-check-cached-permissions v ?r)))
 566
 567 (defun tramp-archive-handle-file-system-info (filename)
 568   "Like `file-system-info' for file archives."
 569   (with-parsed-tramp-archive-file-name filename nil
 570     (list (tramp-compat-file-attribute-size (file-attributes archive)) 0 0)))
 571
 572 (defun tramp-archive-handle-file-truename (filename)
 573   "Like `file-truename' for file archives."
 574   (with-parsed-tramp-archive-file-name filename nil
 575     (let ((local (or (file-symlink-p filename) localname)))
 576       (unless (file-name-absolute-p local)
 577         (setq local (expand-file-name local (file-name-directory localname))))
 578       (concat (file-truename archive) local))))
 579
 580 (defun tramp-archive-handle-insert-directory
 581   (filename switches &optional wildcard full-directory-p)
 582   "Like `insert-directory' for file archives."
 583   (insert-directory
 584    (tramp-archive-gvfs-file-name filename) switches wildcard full-directory-p)
 585   (goto-char (point-min))
 586   (while (search-forward (tramp-archive-gvfs-file-name filename) nil 'noerror)
 587     (replace-match filename)))
 588
 589 (defun tramp-archive-handle-insert-file-contents
 590   (filename &optional visit beg end replace)
 591   "Like `insert-file-contents' for file archives."
 592   (let ((result
 593          (insert-file-contents
 594           (tramp-archive-gvfs-file-name filename) visit beg end replace)))
 595     (prog1
 596         (list (expand-file-name filename)
 597               (cadr result))
 598       (when visit (setq buffer-file-name filename)))))
 599
 600 (defun tramp-archive-handle-load
 601     (file &optional noerror nomessage nosuffix must-suffix)
 602   "Like `load' for file archives."
 603   (load
 604    (tramp-archive-gvfs-file-name file) noerror nomessage nosuffix must-suffix))
 605
 606 (defun tramp-archive-handle-temporary-file-directory ()
 607   "Like `temporary-file-directory' for file archives."
 608   ;; If the default directory, the file archive, is located on a
 609   ;; mounted directory, it is returned as it.  Not what we want.
 610   (with-parsed-tramp-archive-file-name default-directory nil
 611     (let ((default-directory (file-name-directory archive)))
 612       (tramp-compat-temporary-file-directory))))
 613
 614 (defun tramp-archive-handle-not-implemented (operation &rest args)
 615   "Generic handler for operations not implemented for file archives."
 616   (let ((v (ignore-errors
 617              (tramp-archive-dissect-file-name
 618               (apply 'tramp-archive-file-name-for-operation operation args)))))
 619     (tramp-message v 10 "%s" (cons operation args))
 620     (tramp-error
 621      v 'file-error
 622      "Operation `%s' not implemented for file archives" operation)))
 623
 624 (add-hook 'tramp-unload-hook
 625           (lambda ()
 626             (unload-feature 'tramp-archive 'force)))
 627
 628 (provide 'tramp-archive)
 629
 630 ;;; TODO:
 631
 632 ;; * Check, whether we could retrieve better file attributes like uid,
 633 ;;   gid, permissions.  See gvfsbackendarchive.c
 634 ;;   (archive_file_set_info_from_entry), where it is commented out.
 635 ;;
 636 ;; * Implement write access, when possible.
 637 ;;   https://bugzilla.gnome.org/show_bug.cgi?id=589617
 638
 639 ;;; tramp-archive.el ends here