[Emacs-diffs] master b9340aa: Fix Bug#30946

[Michael Albinus]

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

    Fix Bug#30946
    
    * doc/misc/tramp.texi (Multi-hops): Mention host name checks.
    
    * lisp/net/tramp.el (tramp-set-syntax, tramp-dissect-file-name)
    (tramp-debug-message, tramp-handle-shell-command):
    * lisp/net/tramp-adb.el (tramp-adb-handle-shell-command):
    * lisp/net/tramp-archive.el (tramp-archive-file-name-handler)
    (tramp-archive-dissect-file-name):
    * lisp/net/tramp-gvfs.el (tramp-gvfs-file-name-handler): Adapt callees.
    
    * lisp/net/tramp-compat.el (tramp-compat-user-error): Move defsubst ---
    
    * lisp/net/tramp-sh.el (tramp-compute-multi-hops): Check for proper
    host names in multi-hop.  (Bug#30946)
    
    * lisp/net/tramp.el (tramp-user-error): ... here.  Make it a defun.
    
    * test/lisp/net/tramp-tests.el (tramp-test03-file-name-host-rules):
    New test.
---
 doc/misc/tramp.texi          |  6 ++++--
 lisp/net/tramp-adb.el        |  2 +-
 lisp/net/tramp-archive.el    |  4 ++--
 lisp/net/tramp-compat.el     |  7 -------
 lisp/net/tramp-gvfs.el       |  2 +-
 lisp/net/tramp-sh.el         | 38 ++++++++++++++++++--------------------
 lisp/net/tramp.el            | 35 ++++++++++++++++++++++++++++++-----
 test/lisp/net/tramp-tests.el | 23 +++++++++++++++++++++++
 8 files changed, 79 insertions(+), 38 deletions(-)

diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi
index 3143904..f0ea073 100644
--- a/doc/misc/tramp.texi
+++ b/doc/misc/tramp.texi
@@ -1408,8 +1408,10 @@ Opening @address@hidden,randomhost.your.domain,}} first 
connects
 to @samp{randomhost.your.domain} via @code{ssh} under your account
 name, and then performs @code{sudo -u root} on that host.
 
-It is key for the sudo method in the above example to be applied on
-the host after reaching it and not on the local host.
+It is key for the @option{sudo} method in the above example to be
+applied on the host after reaching it and not on the local host.
address@hidden checks therefore, that the host name for such hops
+matches the host name of the previous hop.
 
 @var{host}, @var{user} and @var{proxy} can also take Lisp forms.  These
 forms when evaluated must return either a string or @code{nil}.
diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el
index fbf6196..f8edb27 100644
--- a/lisp/net/tramp-adb.el
+++ b/lisp/net/tramp-adb.el
@@ -999,7 +999,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are 
completely ignored."
     (when p
       (if (yes-or-no-p "A command is running.  Kill it? ")
          (ignore-errors (kill-process p))
-       (tramp-compat-user-error p "Shell command in progress")))
+       (tramp-user-error p "Shell command in progress")))
 
     (if current-buffer-p
        (progn
diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el
index 0b8e8da..448cfca 100644
--- a/lisp/net/tramp-archive.el
+++ b/lisp/net/tramp-archive.el
@@ -311,7 +311,7 @@ pass to the OPERATION."
        (tramp-archive-run-real-handler operation args)
       ;; Now run the handler.
       (unless tramp-archive-enabled
-       (tramp-compat-user-error nil "Package `tramp-archive' not supported"))
+       (tramp-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)
            ;; Set uid and gid.  gvfsd-archive could do it, but it doesn't.
@@ -398,7 +398,7 @@ hexified archive name as host, and the localname.  The 
archive
 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))
+      (tramp-user-error nil "Not an archive file name: \"%s\"" name))
     (let* ((localname (tramp-archive-file-name-localname name))
           (archive (file-truename (tramp-archive-file-name-archive name)))
           (vec (make-tramp-file-name
diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el
index 4f564e6..aa0c99b 100644
--- a/lisp/net/tramp-compat.el
+++ b/lisp/net/tramp-compat.el
@@ -97,13 +97,6 @@ Add the extension of F, if existing."
                                     process-name))))
              (setq result t)))))))))
 
-;; `user-error' has appeared in Emacs 24.3.
-(defsubst tramp-compat-user-error (vec-or-proc format &rest args)
-  "Signal a pilot error."
-  (apply
-   'tramp-error vec-or-proc
-   (if (fboundp 'user-error) 'user-error 'error) format args))
-
 ;; `default-toplevel-value' has been declared in Emacs 24.4.
 (unless (fboundp 'default-toplevel-value)
   (defalias 'default-toplevel-value 'symbol-value))
diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el
index d0385f3..33af124 100644
--- a/lisp/net/tramp-gvfs.el
+++ b/lisp/net/tramp-gvfs.el
@@ -751,7 +751,7 @@ Operations not mentioned here will be handled by the 
default Emacs primitives.")
 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-gvfs' not supported"))
+    (tramp-user-error nil "Package `tramp-gvfs' not supported"))
   (let ((fn (assoc operation tramp-gvfs-file-name-handler-alist)))
     (if fn
        (save-match-data (apply (cdr fn) args))
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index 4cdc39e..6327544 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -327,7 +327,6 @@ The string is used in `tramp-methods'.")
 (add-to-list 'tramp-methods
   `("plink"
     (tramp-login-program        "plink")
-    ;; ("%h") must be a single element, see `tramp-compute-multi-hops'.
     (tramp-login-args           (("-l" "%u") ("-P" "%p") ("-ssh") ("-t")
                                 ("%h") ("\"")
                                 (,(format
@@ -4636,25 +4635,24 @@ Goes through the list `tramp-inline-compress-commands'."
           "Method `%s' is not supported for multi-hops."
           (tramp-file-name-method item)))))
 
-    ;; In case the host name is not used for the remote shell
-    ;; command, the user could be misguided by applying a random
-    ;; host name.
-    (let* ((v (car target-alist))
-          (method (tramp-file-name-method v))
-          (host (tramp-file-name-host v)))
-      (unless
-         (or
-          ;; There are multi-hops.
-          (cdr target-alist)
-          ;; The host name is used for the remote shell command.
-          (member '("%h") (tramp-get-method-parameter v 'tramp-login-args))
-          ;; The host is local.  We cannot use `tramp-local-host-p'
-          ;; here, because it opens a connection as well.
-          (string-match tramp-local-host-regexp host))
-       (tramp-error
-        v 'file-error
-        "Host `%s' looks like a remote host, `%s' can only use the local host"
-        host method)))
+    ;; Some methods ("su", "sg", "sudo", "doas", "ksu") do not use the
+    ;; host name in their command template.  In this case, the remote
+    ;; file name must use either a local host name (first hop), or a
+    ;; host name matching the previous hop.
+    (let ((previous-host tramp-local-host-regexp))
+      (setq choices target-alist)
+      (while (setq item (pop choices))
+       (let ((host (tramp-file-name-host item)))
+         (unless
+             (or
+              ;; The host name is used for the remote shell command.
+              (member
+               '("%h") (tramp-get-method-parameter item 'tramp-login-args))
+              ;; The host name must match previous hop.
+              (string-match previous-host host))
+           (tramp-user-error
+            item "Host name `%s' does not match `%s'" host previous-host))
+         (setq previous-host (concat "^" (regexp-quote host) "$")))))
 
     ;; Result.
     target-alist))
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 4497802..43b5e77 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -689,7 +689,7 @@ Used in user option `tramp-syntax'.  There are further 
variables
 to be set, depending on VALUE."
   ;; Check allowed values.
   (unless (memq value (tramp-syntax-values))
-    (tramp-compat-user-error "Wrong `tramp-syntax' %s" tramp-syntax))
+    (tramp-user-error "Wrong `tramp-syntax' %s" tramp-syntax))
   ;; Cleanup existing buffers.
   (unless (eq (symbol-value symbol) value)
     (tramp-cleanup-all-buffers))
@@ -1348,7 +1348,7 @@ to their default values. For the other file name parts, no
 default values are used."
   (save-match-data
     (unless (tramp-tramp-file-p name)
-      (tramp-compat-user-error nil "Not a Tramp file name: \"%s\"" name))
+      (tramp-user-error nil "Not a Tramp file name: \"%s\"" name))
     (if (not (string-match (nth 0 tramp-file-name-structure) name))
         (error "`tramp-file-name-structure' didn't match!")
       (let ((method    (match-string (nth 1 tramp-file-name-structure) name))
@@ -1608,12 +1608,12 @@ ARGUMENTS to actually emit the message (if applicable)."
                    (regexp-opt
                     '("tramp-backtrace"
                       "tramp-compat-funcall"
-                      "tramp-compat-user-error"
                       "tramp-condition-case-unless-debug"
                       "tramp-debug-message"
                       "tramp-error"
                       "tramp-error-with-buffer"
-                      "tramp-message")
+                      "tramp-message"
+                      "tramp-user-error")
                     t)
                    "$")
                   fn)))
@@ -1753,6 +1753,31 @@ an input event arrives.  The other arguments are passed 
to `tramp-error'."
        (when (tramp-file-name-equal-p vec (car tramp-current-connection))
          (setcdr tramp-current-connection (current-time)))))))
 
+;; We must make it a defun, because it is used earlier already.
+(defun tramp-user-error (vec-or-proc fmt-string &rest arguments)
+  "Signal a pilot error."
+  (unwind-protect
+      (apply
+       'tramp-error vec-or-proc
+       ;; `user-error' has appeared in Emacs 24.3.
+       (if (fboundp 'user-error) 'user-error 'error) fmt-string arguments)
+    ;; Save exit.
+    (when (and tramp-message-show-message
+              (not (zerop tramp-verbose))
+              ;; Do not show when flagged from outside.
+              (not (tramp-completion-mode-p))
+              ;; Show only when Emacs has started already.
+              (current-message))
+      (let ((enable-recursive-minibuffers t))
+       ;; `tramp-error' does not show messages.  So we must do it ourselves.
+       (apply 'message fmt-string arguments)
+       (discard-input)
+       (sit-for 30)
+       ;; Reset timestamp.  It would be wrong after waiting for a while.
+       (when
+           (tramp-file-name-equal-p vec-or-proc (car tramp-current-connection))
+         (setcdr tramp-current-connection (current-time)))))))
+
 (defmacro tramp-with-demoted-errors (vec-or-proc format &rest body)
   "Execute BODY while redirecting the error message to `tramp-message'.
 BODY is executed like wrapped by `with-demoted-errors'.  FORMAT
@@ -3503,7 +3528,7 @@ support symbolic links."
     (when p
       (if (yes-or-no-p "A command is running.  Kill it? ")
          (ignore-errors (kill-process p))
-       (tramp-compat-user-error p "Shell command in progress")))
+       (tramp-user-error p "Shell command in progress")))
 
     (if current-buffer-p
        (progn
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index dfb0112..5e79a4b 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -1722,6 +1722,28 @@ handled properly.  BODY shall not contain a timeout."
   ;; Default values in tramp-smb.el.
   (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 ()
+  "Check host name rules for host-less methods."
+  (skip-unless (tramp--test-enabled))
+  (skip-unless (tramp--test-sh-p))
+
+  ;; Host names must match rules in case the command template of a
+  ;; method doesn't use them.
+  (dolist (m '("su" "sg" "sudo" "doas" "ksu"))
+    ;; Single hop.  The host name must match `tramp-local-host-regexp'.
+    (should-error
+     (find-file (format "/%s:foo:" m))
+     :type 'user-error)
+    ;; Multi hop.  The host name must match the previous hop.
+    (should-error
+     (find-file
+      (format
+       "%s|%s:foo:"
+       (substring (file-remote-p tramp-test-temporary-file-directory) nil -1)
+       m))
+     :type 'user-error)))
+
 (ert-deftest tramp-test04-substitute-in-file-name ()
   "Check `substitute-in-file-name'."
   (should (string-equal (substitute-in-file-name "/method:host:///foo") 
"/foo"))
@@ -1836,6 +1858,7 @@ handled properly.  BODY shall not contain a timeout."
   ;; Mark as failed until bug has been fixed.
   :expected-result :failed
   (skip-unless (tramp--test-enabled))
+
   ;; These are the methods the test doesn't fail.
   (when (or (tramp--test-adb-p) (tramp--test-gvfs-p)
            (tramp-smb-file-name-p tramp-test-temporary-file-directory))