[Emacs-diffs] master fd6972a: Fix Bug#30262

[Michael Albinus]

branch: master
commit fd6972ac0720bde830728254b8d791c81e01d63f
Author: Michael Albinus <address@hidden>
Commit: Michael Albinus <address@hidden>

    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.
---
 lisp/net/tramp-archive.el                        | 111 ++++++++++++-----------
 lisp/net/tramp-gvfs.el                           |  17 ++--
 test/lisp/net/tramp-archive-resources/foo.tar.gz | Bin 234 -> 274 bytes
 test/lisp/net/tramp-archive-tests.el             |  32 ++++---
 4 files changed, 84 insertions(+), 76 deletions(-)

diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el
index 45e3bf0..ac8b76b 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 6745ae0..70ac077 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 68925b1..0d2e987 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 149ed37..82dd5de 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))))