procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fix Bug#30262

Browse source 
* lisp/net/tramp-archive.el (tramp-archive-hash): Document (changed)
layout.
(tramp-archive-dissect-file-name): Merge with
`tramp-archive-local-copy', which has been removed by this.
(tramp-archive-cleanup-hash): Adapt to changed
`tramp-archive-hash'.  (Bug#30262)

* lisp/net/tramp-gvfs.el (tramp-gvfs-unmount): Flush
connection properties.

* test/lisp/net/tramp-archive-tests.el
(tramp-archive-test01-file-name-syntax)
(tramp-archive-test02-file-name-dissect)
(tramp-archive-test16-directory-files)
(tramp-archive-test26-file-name-completion): Adapt to changed
test file.
(tramp-archive-test08-file-local-copy): Be more robust in cleanup.

* test/lisp/net/tramp-archive-resources/foo.tar.gz: Adapt to
extended test.
This commit is contained in:
Michael Albinus 2018-01-30 17:34:02 +01:00
parent 084cfae0e6
commit fd6972ac07
4 changed files with 113 additions and 105 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

169
lisp/net/tramp-archive.el
View file

@ -301,84 +301,10 @@ pass to the OPERATION."
t))
(defvar tramp-archive-hash (make-hash-table :test 'equal)
"Hash table for archive local copies.")
(defun tramp-archive-local-copy (archive)
"Return copy of ARCHIVE, usable by GVFS.
ARCHIVE is the archive component of an archive file name."
(setq archive (file-truename archive))
(let ((tramp-verbose 0))
(with-tramp-connection-property
;; This is just an auxiliary VEC for caching properties.
(make-tramp-file-name :method tramp-archive-method :host archive)
"archive"
(cond
;; File archives inside file archives.
((tramp-archive-file-name-p archive)
(let ((archive
(tramp-make-tramp-file-name
(tramp-archive-dissect-file-name archive) nil 'noarchive)))
;; We call `file-attributes' in order to mount the archive.
(file-attributes archive)
(puthash archive nil tramp-archive-hash)
archive))
;; http://...
((and url-handler-mode
tramp-compat-use-url-tramp-p
(string-match url-handler-regexp archive)
(string-match "https?" (url-type (url-generic-parse-url archive))))
(let* ((url-tramp-protocols
(cons
(url-type (url-generic-parse-url archive))
url-tramp-protocols))
(archive (url-tramp-convert-url-to-tramp archive)))
(puthash archive nil tramp-archive-hash)
archive))
;; GVFS supported schemes.
((or (tramp-gvfs-file-name-p archive)
(not (file-remote-p archive)))
(puthash archive nil tramp-archive-hash)
archive)
;; Anything else. Here we call `file-local-copy', which we
;; have avoided so far.
(t (let ((inhibit-file-name-operation 'file-local-copy)
(inhibit-file-name-handlers
(cons 'jka-compr-handler inhibit-file-name-handlers))
result)
(or (and (setq result (gethash archive tramp-archive-hash nil))
(file-readable-p result))
(puthash
archive
(setq result (file-local-copy archive))
tramp-archive-hash))
result))))))
;;;###tramp-autoload
(defun tramp-archive-cleanup-hash ()
"Remove local copies of archives, used by GVFS."
(maphash
(lambda (key value)
;; Unmount local copy.
(ignore-errors
(let ((tramp-gvfs-methods tramp-archive-all-gvfs-methods)
(file-archive (file-name-as-directory key)))
(tramp-message
(and (tramp-tramp-file-p key) (tramp-dissect-file-name key)) 3
"Unmounting %s" file-archive)
(tramp-gvfs-unmount
(tramp-dissect-file-name
(tramp-archive-gvfs-file-name file-archive)))))
;; Delete local copy.
(ignore-errors (when value (delete-file value)))
(remhash key tramp-archive-hash))
tramp-archive-hash)
(clrhash tramp-archive-hash))
(add-hook 'kill-emacs-hook 'tramp-archive-cleanup-hash)
(add-hook 'tramp-archive-unload-hook
(lambda ()
(remove-hook 'kill-emacs-hook
'tramp-archive-cleanup-hash)))
"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.")
(defun tramp-archive-dissect-file-name (name)
"Return a `tramp-file-name' structure.
@ -391,12 +317,87 @@ name is kept in slot `hop'"
;; The `string-match' happened in `tramp-archive-file-name-p'.
(let ((archive (match-string 1 name))
(localname (match-string 2 name))
(tramp-verbose 0))
(make-tramp-file-name
:method tramp-archive-method :user nil :domain nil :host
(url-hexify-string
(tramp-gvfs-url-file-name (tramp-archive-local-copy archive)))
:port nil :localname localname :hop archive))))
(tramp-verbose 0)
vec copy)
(setq archive (file-truename archive))
(cond
;; The value is already in the hash table.
((setq vec (car (gethash archive tramp-archive-hash))))
;; 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)))
(setq vec
(make-tramp-file-name
:method tramp-archive-method :hop archive
:host (url-hexify-string (tramp-gvfs-url-file-name archive)))))
(puthash archive (list vec) tramp-archive-hash))
;; http://...
((and url-handler-mode
tramp-compat-use-url-tramp-p
(string-match url-handler-regexp archive)
(string-match "https?" (url-type (url-generic-parse-url archive))))
(let* ((url-tramp-protocols
(cons
(url-type (url-generic-parse-url archive))
url-tramp-protocols))
(archive (url-tramp-convert-url-to-tramp archive)))
(setq vec
(make-tramp-file-name
:method tramp-archive-method :hop archive
:host (url-hexify-string (tramp-gvfs-url-file-name archive)))))
(puthash archive (list vec) tramp-archive-hash))
;; GVFS supported schemes.
((or (tramp-gvfs-file-name-p archive)
(not (file-remote-p archive)))
(setq vec
(make-tramp-file-name
:method tramp-archive-method :hop archive
:host (url-hexify-string (tramp-gvfs-url-file-name archive))))
(puthash archive (list vec) tramp-archive-hash))
;; Anything else. Here we call `file-local-copy', which we
;; have avoided so far.
(t (let ((inhibit-file-name-operation 'file-local-copy)
(inhibit-file-name-handlers
(cons 'jka-compr-handler inhibit-file-name-handlers)))
(setq copy (file-local-copy archive)
vec
(make-tramp-file-name
:method tramp-archive-method :hop archive
:host (url-hexify-string (tramp-gvfs-url-file-name copy)))))
(puthash archive (cons vec copy) tramp-archive-hash)))
;; So far, `vec' handles just the mount point. Add `localname'.
(setf (tramp-file-name-localname vec) localname)
vec)))
;;;###tramp-autoload
(defun tramp-archive-cleanup-hash ()
"Remove local copies of archives, used by GVFS."
(maphash
(lambda (key value)
;; Unmount local copy.
(ignore-errors
(tramp-message (car value) 3 "Unmounting %s" (or (cdr value) key))
(tramp-gvfs-unmount (car value)))
;; Delete local copy.
(ignore-errors (delete-file (cdr value)))
(remhash key tramp-archive-hash))
tramp-archive-hash)
(clrhash tramp-archive-hash))
(add-hook 'kill-emacs-hook 'tramp-archive-cleanup-hash)
(add-hook 'tramp-archive-unload-hook
(lambda ()
(remove-hook 'kill-emacs-hook
'tramp-archive-cleanup-hash)))
(defsubst tramp-file-name-archive (vec)
"Extract the archive file name from VEC.

17
lisp/net/tramp-gvfs.el
View file

@ -1778,13 +1778,16 @@ file-notify events."
(defun tramp-gvfs-unmount (vec)
"Unmount the object identified by VEC."
(let ((vec (copy-tramp-file-name vec)))
(setf (tramp-file-name-localname vec) "/"
(tramp-file-name-hop vec) nil)
(when (tramp-gvfs-connection-mounted-p vec)
(tramp-gvfs-send-command
vec "gvfs-mount" "-u"
(tramp-gvfs-url-file-name (tramp-make-tramp-file-name vec))))))
(setf (tramp-file-name-localname vec) "/"
(tramp-file-name-hop vec) nil)
(when (tramp-gvfs-connection-mounted-p vec)
(tramp-gvfs-send-command
vec "gvfs-mount" "-u"
(tramp-gvfs-url-file-name (tramp-make-tramp-file-name vec))))
(while (tramp-gvfs-connection-mounted-p vec)
(read-event nil nil 0.1))
(tramp-flush-connection-properties vec)
(tramp-flush-connection-properties (tramp-get-connection-process vec)))
(defun tramp-gvfs-mount-spec-entry (key value)
"Construct a mount-spec entry to be used in a mount_spec.

BIN
test/lisp/net/tramp-archive-resources/foo.tar.gz
View file

Binary file not shown.

32
test/lisp/net/tramp-archive-tests.el
View file

@ -99,9 +99,9 @@ variables, so we check the Emacs version directly."
(tramp-archive-file-name-p (concat tramp-archive-test-archive "foo/bar")))
;; A file archive inside a file archive.
(should
(tramp-archive-file-name-p (concat tramp-archive-test-archive "foo.tar")))
(tramp-archive-file-name-p (concat tramp-archive-test-archive "baz.tar")))
(should
(tramp-archive-file-name-p (concat tramp-archive-test-archive "foo.tar/"))))
(tramp-archive-file-name-p (concat tramp-archive-test-archive "baz.tar/"))))
(ert-deftest tramp-archive-test02-file-name-dissect ()
"Check archive file name components."
@ -145,13 +145,14 @@ variables, so we check the Emacs version directly."
;; File archive in file archive.
(let* ((tramp-archive-test-file-archive
(concat tramp-archive-test-archive "bar.tar"))
(concat tramp-archive-test-archive "baz.tar"))
(tramp-archive-test-archive
(file-name-as-directory tramp-archive-test-file-archive))
(tramp-methods (cons `(,tramp-archive-method) tramp-methods))
(tramp-gvfs-methods tramp-archive-all-gvfs-methods))
(unwind-protect
(with-parsed-tramp-archive-file-name tramp-archive-test-archive nil
(with-parsed-tramp-archive-file-name
(expand-file-name "bar" tramp-archive-test-archive) nil
(should (string-equal method tramp-archive-method))
(should-not user)
(should-not domain)
@ -184,8 +185,12 @@ variables, so we check the Emacs version directly."
nil "/"))
(file-name-nondirectory tramp-archive-test-file-archive)))))
(should-not port)
(should (string-equal localname "/"))
(should (string-equal archive tramp-archive-test-file-archive)))
(should (string-equal localname "/bar"))
;; The `archive' component is now already a Tramp file name.
(should
(string-equal
archive
(tramp-archive-gvfs-file-name tramp-archive-test-file-archive))))
;; Cleanup.
(tramp-archive-cleanup-hash))))
@ -290,9 +295,8 @@ This checks also `file-name-as-directory', `file-name-directory',
:type tramp-file-missing))
;; Cleanup.
(ignore-errors
(tramp-archive--test-delete tmp-name)
(tramp-archive-cleanup-hash)))))
(ignore-errors (tramp-archive--test-delete tmp-name))
(tramp-archive-cleanup-hash))))
(ert-deftest tramp-archive-test09-insert-file-contents ()
"Check `insert-file-contents'."
@ -444,7 +448,7 @@ This checks also `file-name-as-directory', `file-name-directory',
(skip-unless tramp-gvfs-enabled)
(let ((tmp-name tramp-archive-test-archive)
(files '("." ".." "bar" "foo.hrd" "foo.lnk" "foo.txt")))
(files '("." ".." "bar" "baz.tar" "foo.hrd" "foo.lnk" "foo.txt")))
(unwind-protect
(progn
(should (file-directory-p tmp-name))
@ -656,7 +660,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'."
;; Local files.
(should (equal (file-name-completion "fo" tmp-name) "foo."))
(should (equal (file-name-completion "foo.txt" tmp-name) t))
(should (equal (file-name-completion "b" tmp-name) "bar/"))
(should (equal (file-name-completion "b" tmp-name) "ba"))
(should-not (file-name-completion "a" tmp-name))
(should
(equal
@ -668,18 +672,18 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'."
(should
(equal
(sort (file-name-all-completions "b" tmp-name) 'string-lessp)
'("bar/")))
'("bar/" "baz.tar")))
(should-not (file-name-all-completions "a" tmp-name))
;; `completion-regexp-list' restricts the completion to
;; files which match all expressions in this list.
(let ((completion-regexp-list
`(,directory-files-no-dot-files-regexp "b")))
(should
(equal (file-name-completion "" tmp-name) "bar/"))
(equal (file-name-completion "" tmp-name) "ba"))
(should
(equal
(sort (file-name-all-completions "" tmp-name) 'string-lessp)
'("bar/")))))
'("bar/" "baz.tar")))))
;; Cleanup.
(tramp-archive-cleanup-hash))))