From: Michael Albinus Date: Tue, 30 Jan 2018 16:34:02 +0000 (+0100) Subject: Fix Bug#30262 X-Git-Tag: emacs-27.0.90~5772 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=fd6972ac0720bde830728254b8d791c81e01d63f;p=emacs.git Fix Bug#30262 * 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. --- diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 45e3bf0a606..ac8b76b9442 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -301,27 +301,42 @@ 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" + "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. +The structure consists of the `tramp-archive-method' method, the +hexlified archive name as host, and the localname. The archive +name is kept in slot `hop'" + (save-match-data + (unless (tramp-archive-file-name-p name) + (tramp-compat-user-error nil "Not an archive file name: \"%s\"" name)) + ;; The `string-match' happened in `tramp-archive-file-name-p'. + (let ((archive (match-string 1 name)) + (localname (match-string 2 name)) + (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))) - ;; We call `file-attributes' in order to mount the archive. - (file-attributes archive) - (puthash archive nil tramp-archive-hash) - 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)) + ;; http://... ((and url-handler-mode tramp-compat-use-url-tramp-p @@ -332,26 +347,36 @@ ARCHIVE is the archive component of an archive file name." (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)) + (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))) - (puthash archive nil tramp-archive-hash) - 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)) - 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)))))) + (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 () @@ -360,16 +385,10 @@ ARCHIVE is the archive component of an archive file name." (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))))) + (tramp-message (car value) 3 "Unmounting %s" (or (cdr value) key)) + (tramp-gvfs-unmount (car value))) ;; Delete local copy. - (ignore-errors (when value (delete-file value))) + (ignore-errors (delete-file (cdr value))) (remhash key tramp-archive-hash)) tramp-archive-hash) (clrhash tramp-archive-hash)) @@ -380,24 +399,6 @@ ARCHIVE is the archive component of an archive file name." (remove-hook 'kill-emacs-hook 'tramp-archive-cleanup-hash))) -(defun tramp-archive-dissect-file-name (name) - "Return a `tramp-file-name' structure. -The structure consists of the `tramp-archive-method' method, the -hexlified archive name as host, and the localname. The archive -name is kept in slot `hop'" - (save-match-data - (unless (tramp-archive-file-name-p name) - (tramp-compat-user-error nil "Not an archive file name: \"%s\"" name)) - ;; 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)))) - (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 diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 6745ae02c7b..70ac077a7c5 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -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. diff --git a/test/lisp/net/tramp-archive-resources/foo.tar.gz b/test/lisp/net/tramp-archive-resources/foo.tar.gz index 68925b147fc..0d2e9878dd7 100644 Binary files a/test/lisp/net/tramp-archive-resources/foo.tar.gz and b/test/lisp/net/tramp-archive-resources/foo.tar.gz differ diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index 149ed370432..82dd5de8b9a 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -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))))