Commit 7aaf5007 authored by Michael Albinus's avatar Michael Albinus

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.
parent 512f0364
Pipeline #1890 failed with stage
in 4 seconds
......@@ -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)
......
......@@ -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)
......
......@@ -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)
......
......@@ -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)
......
......@@ -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)
......
......@@ -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))
......
......@@ -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'."
......
This diff is collapsed.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment