[Emacs-diffs] master 84d066a: Fix Bug#30293

[Michael Albinus]

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

    Fix Bug#30293
    
    * lisp/net/tramp-archive.el (tramp-archive-file-name-for-operation):
    New defsubst.
    (tramp-archive-file-name-archive, tramp-archive-file-name-localname):
    New defuns.
    (tramp-archive-file-name-handler, tramp-archive-dissect-file-name)
    (tramp-archive-handle-not-implemented): Use them.  (Bug#30293)
    
    * test/lisp/net/tramp-archive-tests.el (tramp-archive-test-directory):
    New defconst.
    (tramp-archive-test01-file-name-syntax): Extend test.
    (tramp-archive-test05-expand-file-name-non-archive-directory):
    New test.  (Bug#30293)
    
    * test/lisp/net/tramp-archive-resources/foo.iso/foo: New file.
---
 lisp/net/tramp-archive.el                         | 49 +++++++++++++------
 test/lisp/net/tramp-archive-resources/foo.iso/foo |  1 +
 test/lisp/net/tramp-archive-tests.el              | 59 ++++++++++++++++++++++-
 3 files changed, 94 insertions(+), 15 deletions(-)

diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el
index 51ee18f..8d292e1 100644
--- a/lisp/net/tramp-archive.el
+++ b/lisp/net/tramp-archive.el
@@ -253,21 +253,33 @@ It must be supported by libarchive(3).")
   "Alist of handler functions for GVFS archive method.
 Operations not mentioned here will be handled by the default Emacs 
primitives.")
 
+(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)))
+
 ;;;###tramp-autoload
 (defun tramp-archive-file-name-handler (operation &rest args)
   "Invoke the GVFS archive related OPERATION.
 First arg specifies the OPERATION, second arg is a list of arguments to
 pass to the OPERATION."
-  (unless tramp-gvfs-enabled
-    (tramp-compat-user-error nil "Package `tramp-archive' not supported"))
-  (let ((tramp-methods (cons `(,tramp-archive-method) tramp-methods))
-       (tramp-gvfs-methods tramp-archive-all-gvfs-methods)
-       (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-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 (file-directory-p archive)
+       (tramp-run-real-handler operation args)
+      ;; Now run the handler.
+      (unless tramp-gvfs-enabled
+       (tramp-compat-user-error nil "Package `tramp-archive' not supported"))
+      (let ((tramp-methods (cons `(,tramp-archive-method) tramp-methods))
+           (tramp-gvfs-methods tramp-archive-all-gvfs-methods)
+           (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-run-real-handler operation args))))))
 
 ;; Mark `operations' the handler is responsible for.
 (put 'tramp-archive-file-name-handler 'operations
@@ -300,6 +312,16 @@ pass to the OPERATION."
        (string-match tramp-archive-file-name-regexp name)
        t))
 
+(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)))
+
 (defvar tramp-archive-hash (make-hash-table :test 'equal)
   "Hash table for archive local copies.
 The hash key is the archive name.  The value is a cons of the
@@ -314,9 +336,8 @@ 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* ((localname (match-string 2 name))
-          (archive (file-truename (match-string 1 name)))
+    (let* ((localname (tramp-archive-file-name-localname name))
+          (archive (file-truename (tramp-archive-file-name-archive name)))
           (vec (make-tramp-file-name
                 :method tramp-archive-method :hop archive)))
 
@@ -535,7 +556,7 @@ offered."
   "Generic handler for operations not implemented for file archives."
   (let ((v (ignore-errors
             (tramp-archive-dissect-file-name
-             (apply 'tramp-file-name-for-operation operation args)))))
+             (apply 'tramp-archive-file-name-for-operation operation args)))))
     (tramp-message v 10 "%s" (cons operation args))
     (tramp-error
      v 'file-error
diff --git a/test/lisp/net/tramp-archive-resources/foo.iso/foo 
b/test/lisp/net/tramp-archive-resources/foo.iso/foo
new file mode 100644
index 0000000..257cc56
--- /dev/null
+++ b/test/lisp/net/tramp-archive-resources/foo.iso/foo
@@ -0,0 +1 @@
+foo
diff --git a/test/lisp/net/tramp-archive-tests.el 
b/test/lisp/net/tramp-archive-tests.el
index ecfee0c..96c6a71 100644
--- a/test/lisp/net/tramp-archive-tests.el
+++ b/test/lisp/net/tramp-archive-tests.el
@@ -46,6 +46,11 @@
   (file-name-as-directory tramp-archive-test-file-archive)
   "The test archive.")
 
+(defconst tramp-archive-test-directory
+  (file-truename
+   (expand-file-name "foo.iso" tramp-archive-test-resource-directory))
+  "A directory file name, which looks like an archive.")
+
 (setq password-cache-expiry nil
       tramp-verbose 0
       tramp-cache-read-persistent-data t ;; For auth-sources.
@@ -94,14 +99,51 @@ variables, so we check the Emacs version directly."
   "Check archive file name syntax."
   (should-not (tramp-archive-file-name-p tramp-archive-test-file-archive))
   (should (tramp-archive-file-name-p tramp-archive-test-archive))
+  (should
+   (string-equal
+    (tramp-archive-file-name-archive tramp-archive-test-archive)
+    tramp-archive-test-file-archive))
+  (should
+   (string-equal
+    (tramp-archive-file-name-localname tramp-archive-test-archive) "/"))
   (should (tramp-archive-file-name-p (concat tramp-archive-test-archive 
"foo")))
   (should
+   (string-equal
+    (tramp-archive-file-name-localname
+     (concat tramp-archive-test-archive "foo"))
+    "/foo"))
+  (should
    (tramp-archive-file-name-p (concat tramp-archive-test-archive "foo/bar")))
+  (should
+   (string-equal
+    (tramp-archive-file-name-localname
+     (concat tramp-archive-test-archive "foo/bar"))
+    "/foo/bar"))
   ;; A file archive inside a file archive.
   (should
    (tramp-archive-file-name-p (concat tramp-archive-test-archive "baz.tar")))
   (should
-   (tramp-archive-file-name-p (concat tramp-archive-test-archive "baz.tar/"))))
+   (string-equal
+    (tramp-archive-file-name-archive
+     (concat tramp-archive-test-archive "baz.tar"))
+    tramp-archive-test-file-archive))
+  (should
+   (string-equal
+    (tramp-archive-file-name-localname
+     (concat tramp-archive-test-archive "baz.tar"))
+    "/baz.tar"))
+  (should
+   (tramp-archive-file-name-p (concat tramp-archive-test-archive "baz.tar/")))
+  (should
+   (string-equal
+    (tramp-archive-file-name-archive
+     (concat tramp-archive-test-archive "baz.tar/"))
+    (concat tramp-archive-test-archive "baz.tar")))
+  (should
+   (string-equal
+    (tramp-archive-file-name-localname
+     (concat tramp-archive-test-archive "baz.tar/"))
+    "/")))
 
 (ert-deftest tramp-archive-test02-file-name-dissect ()
   "Check archive file name components."
@@ -205,6 +247,21 @@ variables, so we check the Emacs version directly."
   (should (string-equal (expand-file-name "/foo.tar/./file") "/foo.tar/file"))
   (should (string-equal (expand-file-name "/foo.tar/../file") "/file")))
 
+;; This test is inspired by Bug#30293.
+(ert-deftest tramp-archive-test05-expand-file-name-non-archive-directory ()
+  "Check existing directories with archive file name syntax.
+They shall still be supported"
+  (should (file-directory-p tramp-archive-test-directory))
+  ;; `tramp-archive-file-name-p' tests only for file name syntax.  It
+  ;; doesn't test, whether it is really a file archive.
+  (should
+   (tramp-archive-file-name-p
+    (file-name-as-directory tramp-archive-test-directory)))
+  (should
+   (file-directory-p (file-name-as-directory tramp-archive-test-directory)))
+  (should
+   (file-exists-p (expand-file-name "foo" tramp-archive-test-directory))))
+
 (ert-deftest tramp-archive-test06-directory-file-name ()
   "Check `directory-file-name'.
 This checks also `file-name-as-directory', `file-name-directory',