From a2cb52cd2e7c497df51d751b91b331f59f9637e7 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sat, 3 Feb 2018 18:49:56 +0100 Subject: [PATCH] Prevent loading tramp-archive when it cannot be used * lisp/files.el (locate-dominating-file): Check, that FILE is a directory when traversing the tree. * lisp/net/tramp-archive.el (tramp-archive-enabled): New defvar. (tramp-archive-file-name-regexp): Protect against errors. (tramp-archive-file-name-handler) (tramp-register-archive-file-name-handler): Use it. (all) Call `tramp-register-archive-file-name-handler'. * lisp/net/tramp.el (tramp-register-file-name-handlers): Use `tramp-archive-enabled'. * test/lisp/net/tramp-archive-tests.el (all): Use `tramp-archive-enabled' instead of `tramp-gvfs-enabled'. (tramp-archive--test-emacs27-p): New defun. (tramp-archive-test42-auto-load): Skip for older Emacsen. (tramp-archive-test42-delay-load): Skip for older Emacsen. Test also behavior when `tramp-archive-enabled' is nil. --- lisp/files.el | 3 +- lisp/net/tramp-archive.el | 23 ++++-- lisp/net/tramp.el | 9 +-- test/lisp/net/tramp-archive-tests.el | 102 +++++++++++++++------------ 4 files changed, 82 insertions(+), 55 deletions(-) diff --git a/lisp/files.el b/lisp/files.el index e884a3acc18..414eb3f93af 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -963,7 +963,8 @@ the function needs to examine, starting with FILE." (null file) (string-match locate-dominating-stop-dir-regexp file))) (setq try (if (stringp name) - (file-exists-p (expand-file-name name file)) + (and (file-directory-p file) + (file-exists-p (expand-file-name name file))) (funcall name file))) (cond (try (setq root file)) ((equal file (setq file (file-name-directory diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 23191f11f3e..ac1c4e1448d 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -112,6 +112,14 @@ (defvar url-handler-regexp) (defvar url-tramp-protocols) +;; We cannot check `tramp-gvfs-enabled' in loaddefs.el, because this +;; would load Tramp. So we make a cheaper check. +;;;###autoload +(defvar tramp-archive-enabled (featurep 'dbusbind) + "Non-nil when GVFS is available.") + +(setq tramp-archive-enabled tramp-gvfs-enabled) + ;; ;;;###autoload (defconst tramp-archive-suffixes @@ -169,7 +177,7 @@ It must be supported by libarchive(3).") ;;;###tramp-autoload (defconst tramp-archive-file-name-regexp - (tramp-archive-autoload-file-name-regexp) + (ignore-errors (tramp-archive-autoload-file-name-regexp)) "Regular expression matching archive file names.") ;;;###tramp-autoload @@ -291,7 +299,7 @@ pass to the OPERATION." (tramp-archive-run-real-handler 'file-directory-p (list archive))) (tramp-archive-run-real-handler operation args) ;; Now run the handler. - (unless tramp-gvfs-enabled + (unless tramp-archive-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) @@ -308,14 +316,17 @@ pass to the OPERATION." ;;;###autoload (progn (defun tramp-register-archive-file-name-handler () "Add archive file name handler to `file-name-handler-alist'." - (add-to-list 'file-name-handler-alist - (cons (tramp-archive-autoload-file-name-regexp) - 'tramp-autoload-file-name-handler)) - (put 'tramp-archive-file-name-handler 'safe-magic t))) + (when tramp-archive-enabled + (add-to-list 'file-name-handler-alist + (cons (tramp-archive-autoload-file-name-regexp) + 'tramp-autoload-file-name-handler)) + (put 'tramp-archive-file-name-handler 'safe-magic t)))) ;;;###autoload (add-hook 'after-init-hook 'tramp-register-archive-file-name-handler) +(tramp-register-archive-file-name-handler) + ;; Mark `operations' the handler is responsible for. (put 'tramp-archive-file-name-handler 'operations (mapcar 'car tramp-archive-file-name-handler-alist)) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 5a2e358daa1..09abd482260 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -2401,10 +2401,11 @@ remote file names." (put 'tramp-completion-file-name-handler 'operations (mapcar 'car tramp-completion-file-name-handler-alist)) - (add-to-list 'file-name-handler-alist - (cons tramp-archive-file-name-regexp - 'tramp-archive-file-name-handler)) - (put 'tramp-archive-file-name-handler 'safe-magic t) + (when (bound-and-true-p tramp-archive-enabled) + (add-to-list 'file-name-handler-alist + (cons tramp-archive-file-name-regexp + 'tramp-archive-file-name-handler)) + (put 'tramp-archive-file-name-handler 'safe-magic t)) ;; If jka-compr or epa-file are already loaded, move them to the ;; front of `file-name-handler-alist'. diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index bebdf108c66..e4ae1217002 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -86,12 +86,18 @@ Some semantics has been changed for there, w/o new functions or variables, so we check the Emacs version directly." (>= emacs-major-version 26)) +(defun tramp-archive--test-emacs27-p () + "Check for Emacs version >= 27.1. +Some semantics has been changed for there, w/o new functions or +variables, so we check the Emacs version directly." + (>= emacs-major-version 27)) + (ert-deftest tramp-archive-test00-availability () - "Test availability of Tramp functions." - :expected-result (if tramp-gvfs-enabled :passed :failed) + "Test availability of archive file name functions." + :expected-result (if tramp-archive-enabled :passed :failed) (should (and - tramp-gvfs-enabled + tramp-archive-enabled (file-exists-p tramp-archive-test-file-archive) (tramp-archive-file-name-p tramp-archive-test-archive)))) @@ -147,7 +153,7 @@ variables, so we check the Emacs version directly." (ert-deftest tramp-archive-test02-file-name-dissect () "Check archive file name components." - (skip-unless tramp-gvfs-enabled) + (skip-unless tramp-archive-enabled) (with-parsed-tramp-archive-file-name tramp-archive-test-archive nil (should (string-equal method tramp-archive-method)) @@ -266,7 +272,7 @@ They shall still be supported" "Check `directory-file-name'. This checks also `file-name-as-directory', `file-name-directory', `file-name-nondirectory' and `unhandled-file-name-directory'." - (skip-unless tramp-gvfs-enabled) + (skip-unless tramp-archive-enabled) (should (string-equal @@ -305,7 +311,7 @@ This checks also `file-name-as-directory', `file-name-directory', (ert-deftest tramp-archive-test07-file-exists-p () "Check `file-exist-p', `write-region' and `delete-file'." - (skip-unless tramp-gvfs-enabled) + (skip-unless tramp-archive-enabled) (unwind-protect (let ((default-directory tramp-archive-test-archive)) @@ -327,7 +333,7 @@ This checks also `file-name-as-directory', `file-name-directory', (ert-deftest tramp-archive-test08-file-local-copy () "Check `file-local-copy'." - (skip-unless tramp-gvfs-enabled) + (skip-unless tramp-archive-enabled) (let (tmp-name) (unwind-protect @@ -353,7 +359,7 @@ This checks also `file-name-as-directory', `file-name-directory', (ert-deftest tramp-archive-test09-insert-file-contents () "Check `insert-file-contents'." - (skip-unless tramp-gvfs-enabled) + (skip-unless tramp-archive-enabled) (let ((tmp-name (expand-file-name "bar/bar" tramp-archive-test-archive))) (unwind-protect @@ -379,7 +385,7 @@ This checks also `file-name-as-directory', `file-name-directory', (ert-deftest tramp-archive-test11-copy-file () "Check `copy-file'." - (skip-unless tramp-gvfs-enabled) + (skip-unless tramp-archive-enabled) ;; Copy simple file. (let ((tmp-name1 (expand-file-name "bar/bar" tramp-archive-test-archive)) @@ -444,7 +450,7 @@ This checks also `file-name-as-directory', `file-name-directory', (ert-deftest tramp-archive-test15-copy-directory () "Check `copy-directory'." - (skip-unless tramp-gvfs-enabled) + (skip-unless tramp-archive-enabled) (let* ((tmp-name1 (expand-file-name "bar" tramp-archive-test-archive)) (tmp-name2 (tramp-archive--test-make-temp-name)) @@ -498,7 +504,7 @@ This checks also `file-name-as-directory', `file-name-directory', (ert-deftest tramp-archive-test16-directory-files () "Check `directory-files'." - (skip-unless tramp-gvfs-enabled) + (skip-unless tramp-archive-enabled) (let ((tmp-name tramp-archive-test-archive) (files '("." ".." "bar" "baz.tar" "foo.hrd" "foo.lnk" "foo.txt"))) @@ -521,7 +527,7 @@ This checks also `file-name-as-directory', `file-name-directory', (ert-deftest tramp-archive-test17-insert-directory () "Check `insert-directory'." - (skip-unless tramp-gvfs-enabled) + (skip-unless tramp-archive-enabled) (let (;; We test for the summary line. Keyword "total" could be localized. (process-environment @@ -563,7 +569,7 @@ This checks also `file-name-as-directory', `file-name-directory', (ert-deftest tramp-archive-test18-file-attributes () "Check `file-attributes'. This tests also `file-readable-p' and `file-regular-p'." - (skip-unless tramp-gvfs-enabled) + (skip-unless tramp-archive-enabled) (let ((tmp-name1 (expand-file-name "foo.txt" tramp-archive-test-archive)) (tmp-name2 (expand-file-name "foo.lnk" tramp-archive-test-archive)) @@ -613,7 +619,7 @@ This tests also `file-readable-p' and `file-regular-p'." (ert-deftest tramp-archive-test19-directory-files-and-attributes () "Check `directory-files-and-attributes'." - (skip-unless tramp-gvfs-enabled) + (skip-unless tramp-archive-enabled) (let ((tmp-name (expand-file-name "bar" tramp-archive-test-archive)) attr) @@ -638,7 +644,7 @@ This tests also `file-readable-p' and `file-regular-p'." (ert-deftest tramp-archive-test20-file-modes () "Check `file-modes'. This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." - (skip-unless tramp-gvfs-enabled) + (skip-unless tramp-archive-enabled) (let ((tmp-name1 (expand-file-name "foo.txt" tramp-archive-test-archive)) (tmp-name2 (expand-file-name "bar" tramp-archive-test-archive))) @@ -667,7 +673,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (ert-deftest tramp-archive-test21-file-links () "Check `file-symlink-p' and `file-truename'" - (skip-unless tramp-gvfs-enabled) + (skip-unless tramp-archive-enabled) ;; We must use `file-truename' for the file archive, because it ;; could be located on a symlinked directory. This would let the @@ -705,7 +711,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (ert-deftest tramp-archive-test26-file-name-completion () "Check `file-name-completion' and `file-name-all-completions'." - (skip-unless tramp-gvfs-enabled) + (skip-unless tramp-archive-enabled) (let ((tmp-name tramp-archive-test-archive)) (unwind-protect @@ -744,7 +750,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." ;; The functions were introduced in Emacs 26.1. (ert-deftest tramp-archive-test37-make-nearby-temp-file () "Check `make-nearby-temp-file' and `temporary-file-directory'." - (skip-unless tramp-gvfs-enabled) + (skip-unless tramp-archive-enabled) ;; Since Emacs 26.1. (skip-unless (and (fboundp 'make-nearby-temp-file) (fboundp 'temporary-file-directory))) @@ -781,7 +787,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (ert-deftest tramp-archive-test40-file-system-info () "Check that `file-system-info' returns proper values." - (skip-unless tramp-gvfs-enabled) + (skip-unless tramp-archive-enabled) ;; Since Emacs 27.1. (skip-unless (fboundp 'file-system-info)) @@ -798,7 +804,9 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (ert-deftest tramp-archive-test42-auto-load () "Check that `tramp-archive' autoloads properly." - (skip-unless tramp-gvfs-enabled) + (skip-unless tramp-archive-enabled) + ;; Autoloading tramp-archive works since Emacs 27.1. + (skip-unless (tramp-archive--test-emacs27-p)) (let ((default-directory (expand-file-name temporary-file-directory)) (code @@ -818,38 +826,44 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (ert-deftest tramp-archive-test42-delay-load () "Check that `tramp-archive' is loaded lazily, only when needed." - (skip-unless tramp-gvfs-enabled) + (skip-unless tramp-archive-enabled) + ;; Autoloading tramp-archive works since Emacs 27.1. + (skip-unless (tramp-archive--test-emacs27-p)) - ;; Tramp is neither loaded at Emacs startup, nor when completing a - ;; non archive file name like "/foo". Completing an archive file - ;; name like "/foo.tar/" autoloads Tramp, when `tramp-mode' is t. + ;; tramp-archive is neither loaded at Emacs startup, nor when + ;; loading a file like "/foo.tar". It is loaded only when + ;; `tramp-archive-enabled' is t. (let ((default-directory (expand-file-name temporary-file-directory)) (code + "(progn \ + (setq tramp-archive-enabled %s) \ + (message \"Tramp loaded: %%s\" (featurep 'tramp-archive)) \ + (find-file %S \"/\") \ + (message \"Tramp loaded: %%s\" (featurep 'tramp-archive)) \ + (file-attributes %S \"/\") \ + (message \"Tramp loaded: %%s\" (featurep 'tramp-archive)))")) + ;; tramp-archive doesn't load when `tramp-archive-enabled' is nil. + (dolist (tae '(t nil)) + (should + (string-match + (format + "Tramp loaded: nil[[:ascii:]]+Tramp loaded: nil[[:ascii:]]+Tramp loaded: %s" + tae) + (shell-command-to-string (format - "(progn \ - (message \"Tramp loaded: %%s\" (featurep 'tramp-archive)) \ - (file-name-all-completions %S \"/\") \ - (message \"Tramp loaded: %%s\" (featurep 'tramp-archive)) \ - (file-name-all-completions %S \"/\") \ - (message \"Tramp loaded: %%s\" (featurep 'tramp-archive)))" - tramp-archive-test-file-archive - tramp-archive-test-archive))) - ;; Tramp doesn't load when `tramp-mode' is nil. - (should - (string-match - "Tramp loaded: nil[\n\r]+Tramp loaded: nil[\n\r]+Tramp loaded: t[\n\r]+" - (shell-command-to-string - (format - "%s -batch -Q -L %s --eval %s" - (shell-quote-argument - (expand-file-name invocation-name invocation-directory)) - (mapconcat 'shell-quote-argument load-path " -L ") - (shell-quote-argument code))))))) + "%s -batch -Q -L %s --eval %s" + (shell-quote-argument + (expand-file-name invocation-name invocation-directory)) + (mapconcat 'shell-quote-argument load-path " -L ") + (shell-quote-argument + (format + code tae tramp-archive-test-file-archive + (concat tramp-archive-test-archive "foo")))))))))) (ert-deftest tramp-archive-test99-libarchive-tests () "Run tests of libarchive test files." :tags '(:expensive-test) - (skip-unless tramp-gvfs-enabled) + (skip-unless tramp-archive-enabled) ;; We do not want to run unless chosen explicitly. This test makes ;; sense only in my local environment. Michael Albinus. (skip-unless -- 2.39.2