tramp-archive.el 27.3 KB
Newer Older
1 2
;;; tramp-archive.el --- Tramp archive manager  -*- lexical-binding:t -*-

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 2017-2019 Free Software Foundation, Inc.
4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61

;; Author: Michael Albinus <michael.albinus@gmx.de>
;; 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
62 63
;; * ".lzh", ".LZH" - Microsoft Windows compressed LHA archives
;; * ".msu", ".MSU" - Microsoft Windows Update packages
64
;; * ".mtree" - BSD mtree format
65
;; * ".odb" ".odf" ".odg" ".odp" ".ods" ".odt" - OpenDocument formats
66 67 68 69
;; * ".pax" - Posix archives
;; * ".rar" - RAR archives
;; * ".rpm" - Red Hat packages
;; * ".shar" - Shell archives
70
;; * ".tar", ".tbz", ".tgz", ".tlz", ".txz" - (Compressed) tape archives
71 72
;; * ".warc" - Web archives
;; * ".xar" - macOS XAR archives
73
;; * ".xpi" - XPInstall Mozilla addons
74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109
;; * ".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: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 tramp-gvfs.el perform better,
;; because no local copy of the file archive must be downloaded first.
;; For example, "/sftp:user@host:..." performs better than the similar
;; "/scp:user@host:...".  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:

110
(eval-when-compile (require 'cl-lib))
Michael Albinus's avatar
Michael Albinus committed
111 112 113 114
;; Sometimes, compilation fails with "Variable binding depth exceeds
;; max-specpdl-size".
(eval-and-compile
  (let ((max-specpdl-size (* 2 max-specpdl-size))) (require 'tramp-gvfs)))
115 116 117 118 119 120 121

(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)

122
;; We cannot check `tramp-gvfs-enabled' in loaddefs.el, because this
Michael Albinus's avatar
Michael Albinus committed
123
;; would load Tramp.  So we make a cheaper check.
124 125
;;;###autoload
(defvar tramp-archive-enabled (featurep 'dbusbind)
126
  "Non-nil when file archive support is available.")
127

128
;; After loading tramp-gvfs.el, we know it better.
129 130
(setq tramp-archive-enabled tramp-gvfs-enabled)

131
;; <https://github.com/libarchive/libarchive/wiki/LibarchiveFormats>
Michael Albinus's avatar
Michael Albinus committed
132
;;;###autoload
133
(defconst tramp-archive-suffixes
134 135 136
  ;; "cab", "lzh", "msu" and "zip" are included with lower and upper
  ;; letters, because Microsoft Windows provides them often with
  ;; capital letters.
137 138 139 140 141 142 143 144 145 146 147
  '("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.
148
    "msu" "MSU" ;; Microsoft Windows Update packages.  Not in testsuite.
149
    "mtree" ;; BSD mtree format.
150
    "odb" "odf" "odg" "odp" "ods" "odt" ;; OpenDocument formats.  Not in testsuite.
151 152 153 154 155 156 157
    "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.
158
    "xpi" ;; XPInstall Mozilla addons.  Not in libarchive testsuite.
159 160 161 162 163 164
    "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>
Michael Albinus's avatar
Michael Albinus committed
165 166
;;    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.
167

Michael Albinus's avatar
Michael Albinus committed
168
;;;###autoload
169 170 171 172 173
(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).")

Michael Albinus's avatar
Michael Albinus committed
174 175 176 177 178 179
;; The definition of `tramp-archive-file-name-regexp' contains calls
;; to `regexp-opt', which cannot be autoloaded while loading
;; loaddefs.el.  So we use a macro, which is evaluated only when needed.
;;;###autoload
(progn (defmacro tramp-archive-autoload-file-name-regexp ()
  "Regular expression matching archive file names."
180
  '(concat
181
    "\\`" "\\(" ".+" "\\."
182 183 184 185
      ;; Default suffixes ...
      (regexp-opt tramp-archive-suffixes)
      ;; ... with compression.
      "\\(?:" "\\." (regexp-opt tramp-archive-compression-suffixes) "\\)*"
186
    "\\)" ;; \1
Michael Albinus's avatar
Michael Albinus committed
187 188
    "\\(" "/" ".*" "\\)" "\\'"))) ;; \2

189 190 191
;; In older Emacsen (prior 27.1), `tramp-archive-autoload-file-name-regexp'
;; is not autoloaded.  So we cannot expect it to be known in
;; tramp-loaddefs.el. But it exists, when tramp-archive.el is loaded.
Michael Albinus's avatar
Michael Albinus committed
192 193
;;;###tramp-autoload
(defconst tramp-archive-file-name-regexp
194
  (ignore-errors (tramp-archive-autoload-file-name-regexp))
195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211
  "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
212
  '((access-file . tramp-archive-handle-access-file)
213 214 215 216
    (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)
Paul Eggert's avatar
Paul Eggert committed
217
    (delete-directory . tramp-archive-handle-not-implemented)
218 219 220 221 222 223 224 225
    (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)
226
    (exec-path . ignore)
227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266
    ;; `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)
    ;; `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)
267
    (make-process . ignore)
268 269 270 271 272 273 274 275 276 277 278
    (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.
Michael Albinus's avatar
Michael Albinus committed
279
    (temporary-file-directory . tramp-archive-handle-temporary-file-directory)
Michael Albinus's avatar
Michael Albinus committed
280
    ;; `tramp-set-file-uid-gid' performed by default handler.
281 282 283 284
    (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))
285
  "Alist of handler functions for file archive method.
286 287
Operations not mentioned here will be handled by the default Emacs primitives.")

Michael Albinus's avatar
Michael Albinus committed
288 289 290 291 292
(defsubst tramp-archive-file-name-for-operation (operation &rest args)
  "Like `tramp-file-name-for-operation', but for archive file name syntax."
  (cl-letf (((symbol-function 'tramp-tramp-file-p) 'tramp-archive-file-name-p))
    (apply 'tramp-file-name-for-operation operation args)))

293 294 295 296 297 298 299 300 301 302 303 304
(defun tramp-archive-run-real-handler (operation args)
  "Invoke normal file name handler for OPERATION.
First arg specifies the OPERATION, second arg is a list of arguments to
pass to the OPERATION."
  (let* ((inhibit-file-name-handlers
	  `(tramp-archive-file-name-handler
	    .
	    ,(and (eq inhibit-file-name-operation operation)
		  inhibit-file-name-handlers)))
	 (inhibit-file-name-operation operation))
    (apply operation args)))

305 306
;;;###tramp-autoload
(defun tramp-archive-file-name-handler (operation &rest args)
307
  "Invoke the file archive related OPERATION.
308 309
First arg specifies the OPERATION, second arg is a list of arguments to
pass to the OPERATION."
Michael Albinus's avatar
Michael Albinus committed
310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336
    (if (not tramp-archive-enabled)
        ;; Unregister `tramp-archive-file-name-handler'.
        (progn
          (tramp-register-file-name-handlers)
          (tramp-archive-run-real-handler operation args))

      (let* ((filename (apply 'tramp-archive-file-name-for-operation
			      operation args))
	     (archive (tramp-archive-file-name-archive filename)))

        ;; The file archive could be a directory, see Bug#30293.
        (if (and archive
	         (tramp-archive-run-real-handler
                  'file-directory-p (list archive)))
            (tramp-archive-run-real-handler operation args)
          ;; Now run the handler.
          (let ((tramp-methods (cons `(,tramp-archive-method) tramp-methods))
	        (tramp-gvfs-methods tramp-archive-all-gvfs-methods)
	        ;; Set uid and gid.  gvfsd-archive could do it, but it doesn't.
	        (tramp-unknown-id-integer (user-uid))
	        (tramp-unknown-id-string (user-login-name))
	        (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-archive-run-real-handler operation args)))))))
337

338 339 340 341
;;;###autoload
(defalias
  'tramp-archive-autoload-file-name-handler 'tramp-autoload-file-name-handler)

Michael Albinus's avatar
Michael Albinus committed
342 343 344
;;;###autoload
(progn (defun tramp-register-archive-file-name-handler ()
  "Add archive file name handler to `file-name-handler-alist'."
345 346 347
  (when tramp-archive-enabled
    (add-to-list 'file-name-handler-alist
	         (cons (tramp-archive-autoload-file-name-regexp)
348 349
		       'tramp-archive-autoload-file-name-handler))
    (put 'tramp-archive-autoload-file-name-handler 'safe-magic t))))
Michael Albinus's avatar
Michael Albinus committed
350 351

;;;###autoload
352 353 354 355 356 357 358 359 360 361
(progn
  (add-hook 'after-init-hook 'tramp-register-archive-file-name-handler)
  (add-hook
   'tramp-archive-unload-hook
   (lambda ()
     (remove-hook
      'after-init-hook 'tramp-register-archive-file-name-handler))))

;; In older Emacsen (prior 27.1), the autoload above does not exist.
;; So we call it again; it doesn't hurt.
362 363
(tramp-register-archive-file-name-handler)

364 365 366 367 368 369 370 371
;; 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
Michael Albinus's avatar
Michael Albinus committed
372 373 374 375 376 377 378
  '(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)))))
379 380 381 382 383 384 385


;; 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)
386
       ;; We cannot use `string-match-p', the matches are used.
387 388 389
       (string-match tramp-archive-file-name-regexp name)
       t))

Michael Albinus's avatar
Michael Albinus committed
390 391 392 393 394 395 396 397 398 399
(defun tramp-archive-file-name-archive (name)
  "Return archive part of NAME."
  (and (tramp-archive-file-name-p name)
       (match-string 1 name)))

(defun tramp-archive-file-name-localname (name)
  "Return localname part of NAME."
  (and (tramp-archive-file-name-p name)
       (match-string 2 name)))

400
(defvar tramp-archive-hash (make-hash-table :test 'equal)
Michael Albinus's avatar
Michael Albinus committed
401 402 403 404 405
  "Hash table for archive local copies.
The hash key is the archive name.  The value is a cons of the
used `tramp-file-name' structure for tramp-gvfs, and the file
name of a local copy, if any.")

406 407 408 409
(defsubst tramp-archive-gvfs-host (archive)
  "Return host name of ARCHIVE as used in GVFS for mounting"
  (url-hexify-string (tramp-gvfs-url-file-name archive)))

Michael Albinus's avatar
Michael Albinus committed
410 411 412
(defun tramp-archive-dissect-file-name (name)
  "Return a `tramp-file-name' structure.
The structure consists of the `tramp-archive-method' method, the
413
hexified archive name as host, and the localname.  The archive
Michael Albinus's avatar
Michael Albinus committed
414 415 416
name is kept in slot `hop'"
  (save-match-data
    (unless (tramp-archive-file-name-p name)
Michael Albinus's avatar
Michael Albinus committed
417
      (tramp-user-error nil "Not an archive file name: \"%s\"" name))
Michael Albinus's avatar
Michael Albinus committed
418 419
    (let* ((localname (tramp-archive-file-name-localname name))
	   (archive (file-truename (tramp-archive-file-name-archive name)))
420 421
	   (vec (make-tramp-file-name
		 :method tramp-archive-method :hop archive)))
Michael Albinus's avatar
Michael Albinus committed
422

423
      (cond
Michael Albinus's avatar
Michael Albinus committed
424
       ;; The value is already in the hash table.
425 426
       ((gethash archive tramp-archive-hash)
	(setq vec (car (gethash archive tramp-archive-hash))))
Michael Albinus's avatar
Michael Albinus committed
427

428 429 430 431 432
       ;; 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)))
433
	  (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive)))
Michael Albinus's avatar
Michael Albinus committed
434 435
	(puthash archive (list vec) tramp-archive-hash))

436 437 438
       ;; http://...
       ((and url-handler-mode
	     tramp-compat-use-url-tramp-p
439 440 441
             (string-match-p url-handler-regexp archive)
	     (string-match-p
	      "https?" (url-type (url-generic-parse-url archive))))
442 443 444 445 446
	(let* ((url-tramp-protocols
		(cons
		 (url-type (url-generic-parse-url archive))
		 url-tramp-protocols))
	       (archive (url-tramp-convert-url-to-tramp archive)))
447
	  (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive)))
448
	(puthash archive (list vec) tramp-archive-hash))
Michael Albinus's avatar
Michael Albinus committed
449

450 451 452
       ;; GVFS supported schemes.
       ((or (tramp-gvfs-file-name-p archive)
	    (not (file-remote-p archive)))
453
	(setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive))
Michael Albinus's avatar
Michael Albinus committed
454 455
	(puthash archive (list vec) tramp-archive-hash))

456 457
       ;; Anything else.  Here we call `file-local-copy', which we
       ;; have avoided so far.
458 459 460 461
       (t (let* ((inhibit-file-name-operation 'file-local-copy)
		 (inhibit-file-name-handlers
		  (cons 'jka-compr-handler inhibit-file-name-handlers))
		 (copy (file-local-copy archive)))
462
	    (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host copy))
463 464 465 466
	    (puthash archive (cons vec copy) tramp-archive-hash))))

      ;; So far, `vec' handles just the mount point.  Add `localname',
      ;; which shouldn't be pushed to the hash.
Michael Albinus's avatar
Michael Albinus committed
467 468
      (setf (tramp-file-name-localname vec) localname)
      vec)))
469 470 471 472 473 474 475

(defun tramp-archive-cleanup-hash ()
  "Remove local copies of archives, used by GVFS."
  (maphash
   (lambda (key value)
     ;; Unmount local copy.
     (ignore-errors
Michael Albinus's avatar
Michael Albinus committed
476 477
       (tramp-message (car value) 3 "Unmounting %s" (or (cdr value) key))
       (tramp-gvfs-unmount (car value)))
478
     ;; Delete local copy.
Michael Albinus's avatar
Michael Albinus committed
479
     (ignore-errors (delete-file (cdr value)))
480 481 482 483
     (remhash key tramp-archive-hash))
   tramp-archive-hash)
  (clrhash tramp-archive-hash))

Michael Albinus's avatar
Michael Albinus committed
484
(add-hook 'tramp-cleanup-all-connections-hook 'tramp-archive-cleanup-hash)
485 486 487
(add-hook 'kill-emacs-hook 'tramp-archive-cleanup-hash)
(add-hook 'tramp-archive-unload-hook
	  (lambda ()
Michael Albinus's avatar
Michael Albinus committed
488 489
	    (remove-hook 'tramp-cleanup-all-connections-hook
			 'tramp-archive-cleanup-hash)
490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535
	    (remove-hook 'kill-emacs-hook
			 'tramp-archive-cleanup-hash)))

(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.

536 537 538 539
(defun tramp-archive-handle-access-file (filename string)
  "Like `access-file' for Tramp files."
  (access-file (tramp-archive-gvfs-file-name filename) string))

540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628
(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))

Michael Albinus's avatar
Michael Albinus committed
629
(defun tramp-archive-handle-temporary-file-directory ()
630
  "Like `temporary-file-directory' for file archives."
Michael Albinus's avatar
Michael Albinus committed
631 632 633 634
  ;; If the default directory, the file archive, is located on a
  ;; mounted directory, it is returned as it.  Not what we want.
  (with-parsed-tramp-archive-file-name default-directory nil
    (let ((default-directory (file-name-directory archive)))
635
      (tramp-compat-temporary-file-directory))))
Michael Albinus's avatar
Michael Albinus committed
636

637 638 639 640
(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
Michael Albinus's avatar
Michael Albinus committed
641
	      (apply 'tramp-archive-file-name-for-operation operation args)))))
642 643 644 645 646 647 648 649 650 651 652 653 654
    (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:

655 656 657
;; * Check, whether we could retrieve better file attributes like uid,
;;   gid, permissions.  See gvfsbackendarchive.c
;;   (archive_file_set_info_from_entry), where it is commented out.
658 659
;;
;; * Implement write access, when possible.
660
;;   https://bugzilla.gnome.org/show_bug.cgi?id=589617
661 662

;;; tramp-archive.el ends here