From 84d066a73fc4191a675c87c81ec1a4f531375e95 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Wed, 31 Jan 2018 15:02:46 +0100 Subject: [PATCH] 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 ++++++++++----- .../net/tramp-archive-resources/foo.iso/foo | 1 + test/lisp/net/tramp-archive-tests.el | 59 ++++++++++++++++++- 3 files changed, 94 insertions(+), 15 deletions(-) create mode 100644 test/lisp/net/tramp-archive-resources/foo.iso/foo diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 51ee18fac7a..8d292e16023 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 00000000000..257cc5642cb --- /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 ecfee0c556c..96c6a71097c 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', -- 2.39.2