From: Michael Albinus Date: Tue, 4 Jun 2019 10:51:45 +0000 (+0200) Subject: Stronger check for Tramp method X-Git-Tag: emacs-27.0.90~2708 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=7aaf500701be3b51c686b7d86c9b505ef5fa9b8f;p=emacs.git Stronger check for Tramp method * lisp/net/tramp-gvfs.el (tramp-gvfs-maybe-open-connection): * lisp/net/tramp-rclone.el (tramp-rclone-maybe-open-connection): * lisp/net/tramp-sudoedit.el (tramp-sudoedit-maybe-open-connection): Use `tramp-get-connection-name'. * lisp/net/tramp-sh.el (tramp-sh-handle-make-symbolic-link): * lisp/net/tramp-smb.el (tramp-smb-handle-make-symbolic-link): * lisp/net/tramp-sudoedit.el (tramp-sudoedit-handle-make-symbolic-link): Don't check remote TARGET. * lisp/net/tramp.el (tramp-dissect-file-name): Check for proper method. (tramp-file-name-for-operation): Take only 2nd argument into account for file name handler. (tramp-file-name-handler): Suppress checks for `file-remote-p'. * test/lisp/net/tramp-archive-tests.el (tramp-archive-test02-file-name-dissect): Suppress check for wrong method. * test/lisp/net/tramp-tests.el (tramp--test-instrument-test-case): Dump *all* Tramp buffers. (tramp-test02-file-name-dissect) (tramp-test02-file-name-dissect-simplified) (tramp-test02-file-name-dissect-separate): Check also wrong method. (tramp-test03-file-name-defaults): Check, that the respective Tramp package is loaded. (tramp-test04-substitute-in-file-name) (tramp-test05-expand-file-name) (tramp-test06-directory-file-name, tramp-test44-auto-load): Suppress check for wrong method. (tramp-test30-make-process): Remove instrumentation code. (tramp-test31-interrupt-process, tramp-test36-vc-registered): Guarantee that connection is established prior starting process. --- diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 38102318240..17c2e79833b 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -1765,7 +1765,7 @@ connection if a previous connection has died for some reason." ;; better solution? (unless (get-buffer-process (tramp-get-connection-buffer vec)) (let ((p (make-network-process - :name (tramp-buffer-name vec) + :name (tramp-get-connection-name vec) :buffer (tramp-get-connection-buffer vec) :server t :host 'local :service t :noquery t))) (process-put p 'vector vec) diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 0148116d739..9e99493cbf6 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -543,7 +543,7 @@ connection if a previous connection has died for some reason." ;; we create a dummy process. Maybe there is a better solution? (unless (get-buffer-process (tramp-get-connection-buffer vec)) (let ((p (make-network-process - :name (tramp-buffer-name vec) + :name (tramp-get-connection-name vec) :buffer (tramp-get-connection-buffer vec) :server t :host 'local :service t :noquery t))) (process-put p 'vector vec) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 2d27baf454a..34fda5af176 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1027,11 +1027,13 @@ component is used as the target of the symlink." (with-parsed-tramp-file-name linkname nil ;; If TARGET is a Tramp name, use just the localname component. - (when (and (tramp-tramp-file-p target) - (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target - (tramp-file-name-localname - (tramp-dissect-file-name (expand-file-name target))))) + ;; Don't check for a proper method. + (let ((non-essential t)) + (when (and (tramp-tramp-file-p target) + (tramp-file-name-equal-p v (tramp-dissect-file-name target))) + (setq target + (tramp-file-name-localname + (tramp-dissect-file-name (expand-file-name target)))))) ;; If TARGET is still remote, quote it. (if (tramp-tramp-file-p target) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 9d15c0562bf..84725db2168 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -1161,11 +1161,13 @@ component is used as the target of the symlink." (with-parsed-tramp-file-name linkname nil ;; If TARGET is a Tramp name, use just the localname component. - (when (and (tramp-tramp-file-p target) - (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target - (tramp-file-name-localname - (tramp-dissect-file-name (expand-file-name target))))) + ;; Don't check for a proper method. + (let ((non-essential t)) + (when (and (tramp-tramp-file-p target) + (tramp-file-name-equal-p v (tramp-dissect-file-name target))) + (setq target + (tramp-file-name-localname + (tramp-dissect-file-name (expand-file-name target)))))) ;; If TARGET is still remote, quote it. (if (tramp-tramp-file-p target) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 0d9e04d0bd1..f056e73366e 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -607,11 +607,13 @@ component is used as the target of the symlink." (with-parsed-tramp-file-name linkname nil ;; If TARGET is a Tramp name, use just the localname component. - (when (and (tramp-tramp-file-p target) - (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target - (tramp-file-name-localname - (tramp-dissect-file-name (expand-file-name target))))) + ;; Don't check for a proper method. + (let ((non-essential t)) + (when (and (tramp-tramp-file-p target) + (tramp-file-name-equal-p v (tramp-dissect-file-name target))) + (setq target + (tramp-file-name-localname + (tramp-dissect-file-name (expand-file-name target)))))) ;; If TARGET is still remote, quote it. (if (tramp-tramp-file-p target) @@ -780,7 +782,7 @@ connection if a previous connection has died for some reason." (throw 'non-essential 'non-essential)) (let ((p (make-network-process - :name (tramp-buffer-name vec) + :name (tramp-get-connection-name vec) :buffer (tramp-get-connection-buffer vec) :server t :host 'local :service t :noquery t))) (process-put p 'vector vec) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index a2558184fb4..f6dd6b5866d 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1435,6 +1435,12 @@ default values are used." (setq v (make-tramp-file-name :method method :user user :domain domain :host host :port port :localname localname :hop hop)) + ;; The method must be known. + (unless (or (tramp-completion-mode-p) + (string-equal method tramp-default-method-marker) + (assoc method tramp-methods)) + (tramp-user-error + v "Method `%s' is not known." method)) ;; Only some methods from tramp-sh.el do support multi-hops. (when (and hop @@ -2175,17 +2181,16 @@ Must be handled by the callers." (if (file-name-absolute-p (nth 0 args)) (nth 0 args) default-directory)) + ;; STRING FILE. + ;; Starting with Emacs 26.1, just the 2nd argument of + ;; `make-symbolic-link' matters. + ((eq operation 'make-symbolic-link) (nth 1 args)) ;; FILE DIRECTORY resp FILE1 FILE2. ((member operation '(add-name-to-file copy-directory copy-file file-equal-p file-in-directory-p file-name-all-completions file-name-completion - ;; Starting with Emacs 26.1, just the 2nd argument of - ;; `make-symbolic-link' matters. For backward - ;; compatibility, we still accept the first argument as - ;; file name to be checked. Handled properly in - ;; `tramp-handle-*-make-symbolic-link'. - file-newer-than-file-p make-symbolic-link rename-file)) + file-newer-than-file-p rename-file)) (cond ((tramp-tramp-file-p (nth 0 args)) (nth 0 args)) ((tramp-tramp-file-p (nth 1 args)) (nth 1 args)) @@ -2280,7 +2285,10 @@ preventing reentrant calls of Tramp.") (defun tramp-file-name-handler (operation &rest args) "Invoke Tramp file name handler. Falls back to normal file name handler if no Tramp file name handler exists." - (let ((filename (apply #'tramp-file-name-for-operation operation args))) + (let ((filename (apply #'tramp-file-name-for-operation operation args)) + ;; `file-remote-p' is called for everything, even for symbolic + ;; links which look remote. We don't want to get an error. + (non-essential (or non-essential (eq operation 'file-remote-p)))) (if (tramp-tramp-file-p filename) (save-match-data (setq filename (tramp-replace-environment-variables filename)) diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index 454279e435e..02fe8edf271 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -157,89 +157,93 @@ variables, so we check the Emacs version directly." "Check archive file name components." (skip-unless tramp-archive-enabled) - (with-parsed-tramp-archive-file-name tramp-archive-test-archive nil - (should (string-equal method tramp-archive-method)) - (should-not user) - (should-not domain) - (should - (string-equal - host - (file-remote-p - (tramp-archive-gvfs-file-name tramp-archive-test-archive) 'host))) - (should - (string-equal - host - (url-hexify-string (concat "file://" tramp-archive-test-file-archive)))) - (should-not port) - (should (string-equal localname "/")) - (should (string-equal archive tramp-archive-test-file-archive))) - - ;; Localname. - (with-parsed-tramp-archive-file-name - (concat tramp-archive-test-archive "foo") nil - (should (string-equal method tramp-archive-method)) - (should-not user) - (should-not domain) - (should - (string-equal - host - (file-remote-p - (tramp-archive-gvfs-file-name tramp-archive-test-archive) 'host))) - (should - (string-equal - host - (url-hexify-string (concat "file://" tramp-archive-test-file-archive)))) - (should-not port) - (should (string-equal localname "/foo")) - (should (string-equal archive tramp-archive-test-file-archive))) - - ;; File archive in file archive. - (let* ((tramp-archive-test-file-archive - (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 - (expand-file-name "bar" tramp-archive-test-archive) nil - (should (string-equal method tramp-archive-method)) - (should-not user) - (should-not domain) - (should - (string-equal - host - (file-remote-p - (tramp-archive-gvfs-file-name tramp-archive-test-archive) 'host))) - ;; We reimplement the logic of tramp-archive.el here. Don't - ;; know, whether it is worth the test. - (should - (string-equal - host - (url-hexify-string - (concat - (tramp-gvfs-url-file-name - (tramp-make-tramp-file-name - tramp-archive-method - ;; User and Domain. - nil nil - ;; Host. - (url-hexify-string - (concat - "file://" - ;; `directory-file-name' does not leave file archive - ;; boundaries. So we must cut the trailing slash - ;; ourselves. - (substring - (file-name-directory tramp-archive-test-file-archive) 0 -1))) - nil "/")) - (file-name-nondirectory tramp-archive-test-file-archive))))) - (should-not port) - (should (string-equal localname "/bar")) - (should (string-equal archive tramp-archive-test-file-archive))) + ;; Suppress method name check. + (let ((non-essential t)) + (with-parsed-tramp-archive-file-name tramp-archive-test-archive nil + (should (string-equal method tramp-archive-method)) + (should-not user) + (should-not domain) + (should + (string-equal + host + (file-remote-p + (tramp-archive-gvfs-file-name tramp-archive-test-archive) 'host))) + (should + (string-equal + host + (url-hexify-string (concat "file://" tramp-archive-test-file-archive)))) + (should-not port) + (should (string-equal localname "/")) + (should (string-equal archive tramp-archive-test-file-archive))) + + ;; Localname. + (with-parsed-tramp-archive-file-name + (concat tramp-archive-test-archive "foo") nil + (should (string-equal method tramp-archive-method)) + (should-not user) + (should-not domain) + (should + (string-equal + host + (file-remote-p + (tramp-archive-gvfs-file-name tramp-archive-test-archive) 'host))) + (should + (string-equal + host + (url-hexify-string (concat "file://" tramp-archive-test-file-archive)))) + (should-not port) + (should (string-equal localname "/foo")) + (should (string-equal archive tramp-archive-test-file-archive))) + + ;; File archive in file archive. + (let* ((tramp-archive-test-file-archive + (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 + (expand-file-name "bar" tramp-archive-test-archive) nil + (should (string-equal method tramp-archive-method)) + (should-not user) + (should-not domain) + (should + (string-equal + host + (file-remote-p + (tramp-archive-gvfs-file-name tramp-archive-test-archive) + 'host))) + ;; We reimplement the logic of tramp-archive.el here. + ;; Don't know, whether it is worth the test. + (should + (string-equal + host + (url-hexify-string + (concat + (tramp-gvfs-url-file-name + (tramp-make-tramp-file-name + tramp-archive-method + ;; User and Domain. + nil nil + ;; Host. + (url-hexify-string + (concat + "file://" + ;; `directory-file-name' does not leave file + ;; archive boundaries. So we must cut the + ;; trailing slash ourselves. + (substring + (file-name-directory tramp-archive-test-file-archive) + 0 -1))) + nil "/")) + (file-name-nondirectory tramp-archive-test-file-archive))))) + (should-not port) + (should (string-equal localname "/bar")) + (should (string-equal archive tramp-archive-test-file-archive))) - ;; Cleanup. - (tramp-archive-cleanup-hash)))) + ;; Cleanup. + (tramp-archive-cleanup-hash))))) (ert-deftest tramp-archive-test05-expand-file-name () "Check `expand-file-name'." diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 5fc37c1934f..38f9af230a3 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -176,10 +176,9 @@ properly. BODY shall not contain a timeout." (let ((tramp--test-instrument-test-case-p t)) ,@body) ;; Unwind forms. (when (and (null tramp--test-instrument-test-case-p) (> tramp-verbose 3)) - (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil - (with-current-buffer (tramp-get-connection-buffer v) - (message "%s" (buffer-string))) - (with-current-buffer (tramp-get-debug-buffer v) + (dolist (buf (tramp-list-tramp-buffers)) + (message ";; %s" buf) + (with-current-buffer buf (message "%s" (buffer-string)))))))) (defsubst tramp--test-message (fmt-string &rest arguments) @@ -412,15 +411,26 @@ properly. BODY shall not contain a timeout." (ert-deftest tramp-test02-file-name-dissect () "Check remote file name components." + ;; `user-error' has appeared in Emacs 24.3. + (skip-unless (fboundp 'user-error)) + (let ((tramp-default-method "default-method") (tramp-default-user "default-user") (tramp-default-host "default-host") tramp-default-method-alist tramp-default-user-alist tramp-default-host-alist + ;; Suppress method name check. + (non-essential t) ;; Suppress check for multihops. (tramp-cache-data (make-hash-table :test #'equal)) (tramp-connection-properties '((nil "login-program" t)))) + ;; An unknown method shall raise an error. + (let (non-essential) + (should-error + (expand-file-name "/method:user@host:") + :type 'user-error)) + ;; Expand `tramp-default-user' and `tramp-default-host'. (should (string-equal (file-remote-p "/method::") @@ -527,7 +537,8 @@ properly. BODY shall not contain a timeout." (should (string-equal (file-remote-p "/-:user@host#1234:" 'method) "default-method")) (should (string-equal (file-remote-p "/-:user@host#1234:" 'user) "user")) - (should (string-equal (file-remote-p "/-:user@host#1234:" 'host) "host#1234")) + (should (string-equal + (file-remote-p "/-:user@host#1234:" 'host) "host#1234")) (should (string-equal (file-remote-p "/-:user@host#1234:" 'localname) "")) (should (string-equal (file-remote-p "/-:user@host#1234:" 'hop) nil)) @@ -563,7 +574,8 @@ properly. BODY shall not contain a timeout." (should (string-equal (file-remote-p "/-:1.2.3.4:") (format "/%s:%s@%s:" "default-method" "default-user" "1.2.3.4"))) - (should (string-equal (file-remote-p "/-:1.2.3.4:" 'method) "default-method")) + (should (string-equal + (file-remote-p "/-:1.2.3.4:" 'method) "default-method")) (should (string-equal (file-remote-p "/-:1.2.3.4:" 'user) "default-user")) (should (string-equal (file-remote-p "/-:1.2.3.4:" 'host) "1.2.3.4")) (should (string-equal (file-remote-p "/-:1.2.3.4:" 'localname) "")) @@ -852,11 +864,16 @@ properly. BODY shall not contain a timeout." (ert-deftest tramp-test02-file-name-dissect-simplified () "Check simplified file name components." :tags '(:expensive-test) + ;; `user-error' has appeared in Emacs 24.3. + (skip-unless (fboundp 'user-error)) + (let ((tramp-default-method "default-method") (tramp-default-user "default-user") (tramp-default-host "default-host") tramp-default-user-alist tramp-default-host-alist + ;; Suppress method name check. + (non-essential t) ;; Suppress check for multihops. (tramp-cache-data (make-hash-table :test #'equal)) (tramp-connection-properties '((nil "login-program" t))) @@ -864,6 +881,12 @@ properly. BODY shall not contain a timeout." (unwind-protect (progn (tramp-change-syntax 'simplified) + ;; An unknown default method shall raise an error. + (let (non-essential) + (should-error + (expand-file-name "/user@host:") + :type 'user-error)) + ;; Expand `tramp-default-method' and `tramp-default-user'. (should (string-equal (file-remote-p "/host:") @@ -1175,12 +1198,17 @@ properly. BODY shall not contain a timeout." (ert-deftest tramp-test02-file-name-dissect-separate () "Check separate file name components." :tags '(:expensive-test) + ;; `user-error' has appeared in Emacs 24.3. + (skip-unless (fboundp 'user-error)) + (let ((tramp-default-method "default-method") (tramp-default-user "default-user") (tramp-default-host "default-host") tramp-default-method-alist tramp-default-user-alist tramp-default-host-alist + ;; Suppress method name check. + (non-essential t) ;; Suppress check for multihops. (tramp-cache-data (make-hash-table :test #'equal)) (tramp-connection-properties '((nil "login-program" t))) @@ -1188,6 +1216,12 @@ properly. BODY shall not contain a timeout." (unwind-protect (progn (tramp-change-syntax 'separate) + ;; An unknown method shall raise an error. + (let (non-essential) + (should-error + (expand-file-name "/[method/user@host]") + :type 'user-error)) + ;; Expand `tramp-default-user' and `tramp-default-host'. (should (string-equal (file-remote-p "/[method/]") @@ -1826,24 +1860,30 @@ properly. BODY shall not contain a timeout." (ert-deftest tramp-test03-file-name-defaults () "Check default values for some methods." ;; Default values in tramp-adb.el. - (should (string-equal (file-remote-p "/adb::" 'host) "")) + (when (assoc "adb" tramp-methods) + (should (string-equal (file-remote-p "/adb::" 'host) ""))) ;; Default values in tramp-ftp.el. - (should (string-equal (file-remote-p "/-:ftp.host:" 'method) "ftp")) - (dolist (u '("ftp" "anonymous")) - (should (string-equal (file-remote-p (format "/-:%s@:" u) 'method) "ftp"))) + (when (assoc "ftp" tramp-methods) + (should (string-equal (file-remote-p "/-:ftp.host:" 'method) "ftp")) + (dolist (u '("ftp" "anonymous")) + (should + (string-equal (file-remote-p (format "/-:%s@:" u) 'method) "ftp")))) ;; Default values in tramp-sh.el and tramp-sudoedit.el. - (dolist (h `("127.0.0.1" "[::1]" "localhost" "localhost6" ,(system-name))) - (should - (string-equal (file-remote-p (format "/-:root@%s:" h) 'method) "su"))) - (dolist (m '("su" "sudo" "ksu" "doas" "sudoedit")) - (should (string-equal (file-remote-p (format "/%s::" m) 'user) "root")) - (should - (string-equal (file-remote-p (format "/%s::" m) 'host) (system-name)))) - (dolist (m '("rcp" "remcp" "rsh" "telnet" "krlogin" "fcp" "nc")) - (should - (string-equal (file-remote-p (format "/%s::" m) 'user) (user-login-name)))) + (when (assoc "su" tramp-methods) + (dolist (h `("127.0.0.1" "[::1]" "localhost" "localhost6" ,(system-name))) + (should + (string-equal (file-remote-p (format "/-:root@%s:" h) 'method) "su"))) + (dolist (m '("su" "sudo" "ksu" "doas" "sudoedit")) + (should (string-equal (file-remote-p (format "/%s::" m) 'user) "root")) + (should + (string-equal (file-remote-p (format "/%s::" m) 'host) (system-name)))) + (dolist (m '("rcp" "remcp" "rsh" "telnet" "krlogin" "fcp" "nc")) + (should + (string-equal + (file-remote-p (format "/%s::" m) 'user) (user-login-name))))) ;; Default values in tramp-smb.el. - (should (string-equal (file-remote-p "/smb::" 'user) nil))) + (when (assoc "smb" tramp-methods) + (should (string-equal (file-remote-p "/smb::" 'user) nil)))) ;; The following test is inspired by Bug#30946. (ert-deftest tramp-test03-file-name-host-rules () @@ -1898,121 +1938,129 @@ properly. BODY shall not contain a timeout." (ert-deftest tramp-test04-substitute-in-file-name () "Check `substitute-in-file-name'." - (should (string-equal (substitute-in-file-name "/method:host:///foo") "/foo")) - (should - (string-equal - (substitute-in-file-name "/method:host://foo") "/method:host:/foo")) - (should - (string-equal (substitute-in-file-name "/method:host:/path///foo") "/foo")) - (should - (string-equal - (substitute-in-file-name "/method:host:/path//foo") "/method:host:/foo")) - ;; Quoting local part. - (should - (string-equal - (substitute-in-file-name "/method:host:/:///foo") "/method:host:/:///foo")) - (should - (string-equal - (substitute-in-file-name "/method:host:/://foo") "/method:host:/://foo")) - (should - (string-equal - (substitute-in-file-name "/method:host:/:/path///foo") - "/method:host:/:/path///foo")) - (should - (string-equal - (substitute-in-file-name "/method:host:/:/path//foo") - "/method:host:/:/path//foo")) - - (should - (string-equal (substitute-in-file-name "/method:host://~foo") "/~foo")) - (should - (string-equal - (substitute-in-file-name "/method:host:/~foo") "/method:host:/~foo")) - (should - (string-equal (substitute-in-file-name "/method:host:/path//~foo") "/~foo")) - ;; (substitute-in-file-name "/path/~foo") expands only for a local - ;; user "foo" to "/~foo"". Otherwise, it doesn't expand. - (should - (string-equal - (substitute-in-file-name - "/method:host:/path/~foo") "/method:host:/path/~foo")) - ;; Quoting local part. - (should - (string-equal - (substitute-in-file-name "/method:host:/://~foo") "/method:host:/://~foo")) - (should - (string-equal - (substitute-in-file-name "/method:host:/:/~foo") "/method:host:/:/~foo")) - (should - (string-equal - (substitute-in-file-name - "/method:host:/:/path//~foo") "/method:host:/:/path//~foo")) - (should - (string-equal - (substitute-in-file-name - "/method:host:/:/path/~foo") "/method:host:/:/path/~foo")) + ;; Suppress method name check. + (let ((tramp-methods (cons '("method") tramp-methods))) + (should + (string-equal (substitute-in-file-name "/method:host:///foo") "/foo")) + (should + (string-equal + (substitute-in-file-name "/method:host://foo") "/method:host:/foo")) + (should + (string-equal (substitute-in-file-name "/method:host:/path///foo") "/foo")) + (should + (string-equal + (substitute-in-file-name "/method:host:/path//foo") "/method:host:/foo")) + ;; Quoting local part. + (should + (string-equal + (substitute-in-file-name "/method:host:/:///foo") + "/method:host:/:///foo")) + (should + (string-equal + (substitute-in-file-name "/method:host:/://foo") "/method:host:/://foo")) + (should + (string-equal + (substitute-in-file-name "/method:host:/:/path///foo") + "/method:host:/:/path///foo")) + (should + (string-equal + (substitute-in-file-name "/method:host:/:/path//foo") + "/method:host:/:/path//foo")) - (let (process-environment) + (should + (string-equal (substitute-in-file-name "/method:host://~foo") "/~foo")) (should (string-equal - (substitute-in-file-name "/method:host:/path/$FOO") - "/method:host:/path/$FOO")) - (setenv "FOO" "bla") + (substitute-in-file-name "/method:host:/~foo") "/method:host:/~foo")) (should (string-equal - (substitute-in-file-name "/method:host:/path/$FOO") - "/method:host:/path/bla")) + (substitute-in-file-name "/method:host:/path//~foo") "/~foo")) + ;; (substitute-in-file-name "/path/~foo") expands only for a local + ;; user "foo" to "/~foo"". Otherwise, it doesn't expand. (should (string-equal - (substitute-in-file-name "/method:host:/path/$$FOO") - "/method:host:/path/$FOO")) + (substitute-in-file-name + "/method:host:/path/~foo") "/method:host:/path/~foo")) ;; Quoting local part. (should (string-equal - (substitute-in-file-name "/method:host:/:/path/$FOO") - "/method:host:/:/path/$FOO")) - (setenv "FOO" "bla") + (substitute-in-file-name "/method:host:/://~foo") + "/method:host:/://~foo")) (should (string-equal - (substitute-in-file-name "/method:host:/:/path/$FOO") - "/method:host:/:/path/$FOO")) + (substitute-in-file-name "/method:host:/:/~foo") "/method:host:/:/~foo")) (should (string-equal - (substitute-in-file-name "/method:host:/:/path/$$FOO") - "/method:host:/:/path/$$FOO")))) + (substitute-in-file-name + "/method:host:/:/path//~foo") "/method:host:/:/path//~foo")) + (should + (string-equal + (substitute-in-file-name + "/method:host:/:/path/~foo") "/method:host:/:/path/~foo")) + + (let (process-environment) + (should + (string-equal + (substitute-in-file-name "/method:host:/path/$FOO") + "/method:host:/path/$FOO")) + (setenv "FOO" "bla") + (should + (string-equal + (substitute-in-file-name "/method:host:/path/$FOO") + "/method:host:/path/bla")) + (should + (string-equal + (substitute-in-file-name "/method:host:/path/$$FOO") + "/method:host:/path/$FOO")) + ;; Quoting local part. + (should + (string-equal + (substitute-in-file-name "/method:host:/:/path/$FOO") + "/method:host:/:/path/$FOO")) + (setenv "FOO" "bla") + (should + (string-equal + (substitute-in-file-name "/method:host:/:/path/$FOO") + "/method:host:/:/path/$FOO")) + (should + (string-equal + (substitute-in-file-name "/method:host:/:/path/$$FOO") + "/method:host:/:/path/$$FOO"))))) (ert-deftest tramp-test05-expand-file-name () "Check `expand-file-name'." - (should - (string-equal - (expand-file-name "/method:host:/path/./file") "/method:host:/path/file")) - (should - (string-equal - (expand-file-name "/method:host:/path/../file") "/method:host:/file")) - (should - (string-equal - (expand-file-name "/method:host:/path/.") "/method:host:/path")) - (should - (string-equal - (expand-file-name "/method:host:/path/..") "/method:host:/")) - (should - (string-equal - (expand-file-name "." "/method:host:/path/") "/method:host:/path")) - (should - (string-equal - (expand-file-name "" "/method:host:/path/") "/method:host:/path")) - ;; Quoting local part. - (should - (string-equal - (expand-file-name "/method:host:/:/path/./file") - "/method:host:/:/path/file")) - (should - (string-equal - (expand-file-name "/method:host:/:/path/../file") "/method:host:/:/file")) - (should - (string-equal - (expand-file-name "/method:host:/:/~/path/./file") - "/method:host:/:/~/path/file"))) + ;; Suppress method name check. + (let ((tramp-methods (cons '("method") tramp-methods))) + (should + (string-equal + (expand-file-name "/method:host:/path/./file") "/method:host:/path/file")) + (should + (string-equal + (expand-file-name "/method:host:/path/../file") "/method:host:/file")) + (should + (string-equal + (expand-file-name "/method:host:/path/.") "/method:host:/path")) + (should + (string-equal + (expand-file-name "/method:host:/path/..") "/method:host:/")) + (should + (string-equal + (expand-file-name "." "/method:host:/path/") "/method:host:/path")) + (should + (string-equal + (expand-file-name "" "/method:host:/path/") "/method:host:/path")) + ;; Quoting local part. + (should + (string-equal + (expand-file-name "/method:host:/:/path/./file") + "/method:host:/:/path/file")) + (should + (string-equal + (expand-file-name "/method:host:/:/path/../file") "/method:host:/:/file")) + (should + (string-equal + (expand-file-name "/method:host:/:/~/path/./file") + "/method:host:/:/~/path/file")))) ;; The following test is inspired by Bug#26911 and Bug#34834. They ;; are rather bugs in `expand-file-name', and it fails for all Emacs @@ -2042,48 +2090,51 @@ properly. BODY shall not contain a timeout." "Check `directory-file-name'. This checks also `file-name-as-directory', `file-name-directory', `file-name-nondirectory' and `unhandled-file-name-directory'." - (should - (string-equal - (directory-file-name "/method:host:/path/to/file") - "/method:host:/path/to/file")) - (should - (string-equal - (directory-file-name "/method:host:/path/to/file/") - "/method:host:/path/to/file")) - (should - (string-equal - (directory-file-name "/method:host:/path/to/file//") - "/method:host:/path/to/file")) - (should - (string-equal - (file-name-as-directory "/method:host:/path/to/file") - "/method:host:/path/to/file/")) - (should - (string-equal - (file-name-as-directory "/method:host:/path/to/file/") - "/method:host:/path/to/file/")) - (should - (string-equal - (file-name-directory "/method:host:/path/to/file") - "/method:host:/path/to/")) - (should - (string-equal - (file-name-directory "/method:host:/path/to/file/") - "/method:host:/path/to/file/")) - (should - (string-equal (file-name-directory "/method:host:file") "/method:host:")) - (should - (string-equal - (file-name-directory "/method:host:path/") "/method:host:path/")) - (should - (string-equal - (file-name-directory "/method:host:path/to") "/method:host:path/")) - (should - (string-equal (file-name-nondirectory "/method:host:/path/to/file") "file")) - (should - (string-equal (file-name-nondirectory "/method:host:/path/to/file/") "")) - (should-not - (unhandled-file-name-directory "/method:host:/path/to/file")) + ;; Suppress method name check. + (let ((tramp-methods (cons '("method") tramp-methods))) + (should + (string-equal + (directory-file-name "/method:host:/path/to/file") + "/method:host:/path/to/file")) + (should + (string-equal + (directory-file-name "/method:host:/path/to/file/") + "/method:host:/path/to/file")) + (should + (string-equal + (directory-file-name "/method:host:/path/to/file//") + "/method:host:/path/to/file")) + (should + (string-equal + (file-name-as-directory "/method:host:/path/to/file") + "/method:host:/path/to/file/")) + (should + (string-equal + (file-name-as-directory "/method:host:/path/to/file/") + "/method:host:/path/to/file/")) + (should + (string-equal + (file-name-directory "/method:host:/path/to/file") + "/method:host:/path/to/")) + (should + (string-equal + (file-name-directory "/method:host:/path/to/file/") + "/method:host:/path/to/file/")) + (should + (string-equal (file-name-directory "/method:host:file") "/method:host:")) + (should + (string-equal + (file-name-directory "/method:host:path/") "/method:host:path/")) + (should + (string-equal + (file-name-directory "/method:host:path/to") "/method:host:path/")) + (should + (string-equal + (file-name-nondirectory "/method:host:/path/to/file") "file")) + (should + (string-equal (file-name-nondirectory "/method:host:/path/to/file/") "")) + (should-not + (unhandled-file-name-directory "/method:host:/path/to/file"))) ;; Bug#10085. (when (tramp--test-enabled) ;; Packages like tramp-gvfs.el might be disabled. @@ -3968,7 +4019,6 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; name handlers since Emacs 27. (skip-unless (tramp--test-emacs27-p)) - (tramp--test-instrument-test-case 0 (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((default-directory tramp-test-temporary-file-directory) (tmp-name (tramp--test-make-temp-name nil quoted)) @@ -4097,7 +4147,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Cleanup. (ignore-errors (delete-process proc)) - (ignore-errors (kill-buffer stderr))))))))) + (ignore-errors (kill-buffer stderr)))))))) (ert-deftest tramp-test31-interrupt-process () "Check `interrupt-process'." @@ -4107,7 +4157,10 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Since Emacs 26.1. (skip-unless (boundp 'interrupt-process-functions)) - (let ((default-directory tramp-test-temporary-file-directory) + ;; We must use `file-truename' for the temporary directory, in + ;; order to establish the connection prior running an asynchronous + ;; process. + (let ((default-directory (file-truename tramp-test-temporary-file-directory)) kill-buffer-query-functions proc) (unwind-protect (with-temp-buffer @@ -4602,7 +4655,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (tramp--test-sh-p)) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) - (let* ((default-directory tramp-test-temporary-file-directory) + ;; We must use `file-truename' for the temporary directory, in + ;; order to establish the connection prior running an asynchronous + ;; process. + (let* ((default-directory + (file-truename tramp-test-temporary-file-directory)) (tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (expand-file-name "foo" tmp-name1)) (tramp-remote-process-environment tramp-remote-process-environment) @@ -5625,7 +5682,9 @@ process sentinels. They shall not disturb each other." (let ((default-directory (expand-file-name temporary-file-directory)) (code (format - "(message \"Tramp loaded: %%s\" (and (file-remote-p %S) t))" + ;; Suppress method name check. + "(let ((non-essential t)) \ + (message \"Tramp loaded: %%s\" (and (file-remote-p %S) t)))" tramp-test-temporary-file-directory))) (should (string-match @@ -5804,9 +5863,9 @@ Since it unloads Tramp, it shall be the last test to run." ;; do not work properly for `nextcloud'. ;; * Fix `tramp-test29-start-file-process' and ;; `tramp-test30-make-process' on MS Windows (`process-send-eof'?). +;; * Implement `tramp-test31-interrupt-process' for `adb'. ;; * Fix Bug#16928 in `tramp-test43-asynchronous-requests'. Looks ;; like it is resolved now. Remove `:unstable' tag? -;; * Implement `tramp-test31-interrupt-process' for `adb'. (provide 'tramp-tests) ;;; tramp-tests.el ends here