From bd07d4fac9da40cecf6a5936fd4b4c8ebb751586 Mon Sep 17 00:00:00 2001
From: Michael Albinus <michael.albinus@gmx.de>
Date: Sun, 13 Feb 2022 20:50:51 +0100
Subject: [PATCH] Improve Tramp's process-file implementations
* lisp/net/tramp-adb.el (tramp-adb-handle-process-file)
* lisp/net/tramp-sh.el (tramp-sh-handle-process-file):
* lisp/net/tramp-smb.el (tramp-smb-handle-process-file):
* lisp/net/tramp-sshfs.el (tramp-sshfs-handle-process-file):
Improve implementation. (Bug#53854)
* test/lisp/net/tramp-tests.el (tramp-test28-process-file)
(tramp--test-check-files, tramp-test47-unload): Extend tests.
---
lisp/net/tramp-adb.el | 6 +-
lisp/net/tramp-sh.el | 4 +-
lisp/net/tramp-smb.el | 2 +-
lisp/net/tramp-sshfs.el | 55 +++++++++++++--
test/lisp/net/tramp-tests.el | 126 ++++++++++++++++++++++++++---------
5 files changed, 153 insertions(+), 40 deletions(-)
diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el
index 85cd2d9bc1e..c683f4c6e8a 100644
--- a/lisp/net/tramp-adb.el
+++ b/lisp/net/tramp-adb.el
@@ -818,7 +818,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(setq infile (tramp-compat-file-name-unquote (expand-file-name infile)))
(if (tramp-equal-remote default-directory infile)
;; INFILE is on the same remote host.
- (setq input (tramp-file-local-name infile))
+ (setq input (tramp-unquote-file-local-name infile))
;; INFILE must be copied to remote host.
(setq input (tramp-make-tramp-temp-file v)
tmpinput (tramp-make-tramp-file-name v input))
@@ -849,7 +849,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(setcar (cdr destination) (expand-file-name (cadr destination)))
(if (tramp-equal-remote default-directory (cadr destination))
;; stderr is on the same remote host.
- (setq stderr (tramp-file-local-name (cadr destination)))
+ (setq stderr (tramp-unquote-file-local-name (cadr destination)))
;; stderr must be copied to remote host. The temporary
;; file must be deleted after execution.
(setq stderr (tramp-make-tramp-temp-file v)
@@ -1264,7 +1264,7 @@ connection if a previous connection has died for some reason."
(if (zerop (length device))
(tramp-error vec 'file-error "Device %s not connected" host))
(with-tramp-progress-reporter vec 3 "Opening adb shell connection"
- (let* ((coding-system-for-read 'utf-8-dos) ;is this correct?
+ (let* ((coding-system-for-read 'utf-8-dos) ; Is this correct?
(process-connection-type tramp-process-connection-type)
(args (if (> (length host) 0)
(list "-s" device "shell")
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index ea089224aef..40ddf106c99 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -3118,7 +3118,7 @@ implementation will be used."
(setq infile (tramp-compat-file-name-unquote (expand-file-name infile)))
(if (tramp-equal-remote default-directory infile)
;; INFILE is on the same remote host.
- (setq input (tramp-file-local-name infile))
+ (setq input (tramp-unquote-file-local-name infile))
;; INFILE must be copied to remote host.
(setq input (tramp-make-tramp-temp-file v)
tmpinput (tramp-make-tramp-file-name v input))
@@ -3149,7 +3149,7 @@ implementation will be used."
(setcar (cdr destination) (expand-file-name (cadr destination)))
(if (tramp-equal-remote default-directory (cadr destination))
;; stderr is on the same remote host.
- (setq stderr (tramp-file-local-name (cadr destination)))
+ (setq stderr (tramp-unquote-file-local-name (cadr destination)))
;; stderr must be copied to remote host. The temporary
;; file must be deleted after execution.
(setq stderr (tramp-make-tramp-temp-file v)
diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el
index 6515519680c..f52fa0a93be 100644
--- a/lisp/net/tramp-smb.el
+++ b/lisp/net/tramp-smb.el
@@ -1284,7 +1284,7 @@ component is used as the target of the symlink."
(setq infile (tramp-compat-file-name-unquote (expand-file-name infile)))
(if (tramp-equal-remote default-directory infile)
;; INFILE is on the same remote host.
- (setq input (tramp-file-local-name infile))
+ (setq input (tramp-unquote-file-local-name infile))
;; INFILE must be copied to remote host.
(setq input (tramp-make-tramp-temp-file v)
tmpinput (tramp-make-tramp-file-name v input))
diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el
index 664dbc31b14..3f23b1a8786 100644
--- a/lisp/net/tramp-sshfs.el
+++ b/lisp/net/tramp-sshfs.el
@@ -240,12 +240,13 @@ arguments to pass to the OPERATION."
(error "Implementation does not handle immediate return"))
(with-parsed-tramp-file-name (expand-file-name default-directory) nil
- (let ((command
+ (let ((coding-system-for-read 'utf-8-dos) ; Is this correct?
+ (command
(format
"cd %s && exec %s"
(tramp-unquote-shell-quote-argument localname)
(mapconcat #'tramp-shell-quote-argument (cons program args) " ")))
- input tmpinput)
+ input tmpinput stderr tmpstderr outbuf)
;; Determine input.
(if (null infile)
@@ -253,18 +254,55 @@ arguments to pass to the OPERATION."
(setq infile (tramp-compat-file-name-unquote (expand-file-name infile)))
(if (tramp-equal-remote default-directory infile)
;; INFILE is on the same remote host.
- (setq input (tramp-file-local-name infile))
+ (setq input (tramp-unquote-file-local-name infile))
;; INFILE must be copied to remote host.
(setq input (tramp-make-tramp-temp-file v)
tmpinput (tramp-make-tramp-file-name v input))
(copy-file infile tmpinput t)))
(when input (setq command (format "%s <%s" command input)))
+ ;; Determine output.
+ (cond
+ ;; Just a buffer.
+ ((bufferp destination)
+ (setq outbuf destination))
+ ;; A buffer name.
+ ((stringp destination)
+ (setq outbuf (get-buffer-create destination)))
+ ;; (REAL-DESTINATION ERROR-DESTINATION)
+ ((consp destination)
+ ;; output.
+ (cond
+ ((bufferp (car destination))
+ (setq outbuf (car destination)))
+ ((stringp (car destination))
+ (setq outbuf (get-buffer-create (car destination))))
+ ((car destination)
+ (setq outbuf (current-buffer))))
+ ;; stderr.
+ (cond
+ ((stringp (cadr destination))
+ (setcar (cdr destination) (expand-file-name (cadr destination)))
+ (if (tramp-equal-remote default-directory (cadr destination))
+ ;; stderr is on the same remote host.
+ (setq stderr (tramp-unquote-file-local-name (cadr destination)))
+ ;; stderr must be copied to remote host. The temporary
+ ;; file must be deleted after execution.
+ (setq stderr (tramp-make-tramp-temp-file v)
+ tmpstderr (tramp-make-tramp-file-name v stderr))))
+ ;; stderr to be discarded.
+ ((null (cadr destination))
+ (setq stderr (tramp-get-remote-null-device v)))))
+ ;; 't
+ (destination
+ (setq outbuf (current-buffer))))
+ (when stderr (setq command (format "%s 2>%s" command stderr)))
+
(unwind-protect
(apply
#'tramp-call-process
v (tramp-get-method-parameter v 'tramp-login-program)
- nil destination display
+ nil outbuf display
(tramp-expand-args
v 'tramp-login-args
?h (or (tramp-file-name-host v) "")
@@ -272,6 +310,15 @@ arguments to pass to the OPERATION."
?p (or (tramp-file-name-port v) "")
?l command))
+ ;; Synchronize stderr.
+ (when tmpstderr
+ (tramp-cleanup-connection v 'keep-debug 'keep-password)
+ (tramp-fuse-unmount v))
+
+ ;; Provide error file.
+ (when tmpstderr
+ (rename-file tmpstderr (cadr destination) t))
+
;; Cleanup. We remove all file cache values for the
;; connection, because the remote process could have changed
;; them.
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index d78e8815b25..baddcd2d7ac 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -4398,6 +4398,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(let* ((tmp-name (tramp--test-make-temp-name nil quoted))
(fnnd (file-name-nondirectory tmp-name))
(default-directory tramp-test-temporary-file-directory)
+ (buffer (get-buffer-create "*tramp-tests*"))
kill-buffer-query-functions)
(unwind-protect
(progn
@@ -4430,31 +4431,47 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(tramp--test-shell-file-name)
nil nil nil "-c" "kill -2 $$")))))
- (with-temp-buffer
- (write-region "foo" nil tmp-name)
- (should (file-exists-p tmp-name))
- (should (zerop (process-file "ls" nil t nil fnnd)))
- ;; "ls" could produce colorized output.
- (goto-char (point-min))
- (while
- (re-search-forward tramp-display-escape-sequence-regexp nil t)
- (replace-match "" nil nil))
- (should (string-equal (format "%s\n" fnnd) (buffer-string)))
- (should-not (get-buffer-window (current-buffer) t))
+ ;; Check DESTINATION.
+ (dolist (destination `(nil t ,buffer))
+ (when (bufferp destination)
+ (with-current-buffer destination
+ (delete-region (point-min) (point-max))))
+ (with-temp-buffer
+ (write-region "foo" nil tmp-name)
+ (should (file-exists-p tmp-name))
+ (should (zerop (process-file "ls" nil destination nil fnnd)))
+ (with-current-buffer
+ (if (bufferp destination) destination (current-buffer))
+ ;; "ls" could produce colorized output.
+ (goto-char (point-min))
+ (while (re-search-forward
+ tramp-display-escape-sequence-regexp nil t)
+ (replace-match "" nil nil))
+ (should
+ (string-equal (if destination (format "%s\n" fnnd) "")
+ (buffer-string)))
+ (should-not (get-buffer-window (current-buffer) t))
+ (goto-char (point-max)))
+
+ ;; Second run. The output must be appended.
+ (should (zerop (process-file "ls" nil destination t fnnd)))
+ (with-current-buffer
+ (if (bufferp destination) destination (current-buffer))
+ ;; "ls" could produce colorized output.
+ (goto-char (point-min))
+ (while (re-search-forward
+ tramp-display-escape-sequence-regexp nil t)
+ (replace-match "" nil nil))
+ (should
+ (string-equal
+ (if destination (format "%s\n%s\n" fnnd fnnd) "")
+ (buffer-string))))
- ;; Second run. The output must be appended.
- (goto-char (point-max))
- (should (zerop (process-file "ls" nil t t fnnd)))
- ;; "ls" could produce colorized output.
- (goto-char (point-min))
- (while
- (re-search-forward tramp-display-escape-sequence-regexp nil t)
- (replace-match "" nil nil))
- (should
- (string-equal (format "%s\n%s\n" fnnd fnnd) (buffer-string)))
- ;; A non-nil DISPLAY must not raise the buffer.
- (should-not (get-buffer-window (current-buffer) t))
- (delete-file tmp-name))
+ (unless (eq destination t)
+ (should (string-empty-p (buffer-string))))
+ ;; A non-nil DISPLAY must not raise the buffer.
+ (should-not (get-buffer-window (current-buffer) t))
+ (delete-file tmp-name)))
;; Check remote and local INFILE.
(dolist (local '(nil t))
@@ -4464,10 +4481,37 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(should (file-exists-p tmp-name))
(should (zerop (process-file "cat" tmp-name t)))
(should (string-equal "foo" (buffer-string)))
- (should-not (get-buffer-window (current-buffer) t)))
- (delete-file tmp-name)))
+ (should-not (get-buffer-window (current-buffer) t))
+ (delete-file tmp-name)))
+
+ ;; Check remote and local DESTNATION file. This isn't
+ ;; implemented yet ina all file name handler backends.
+ ;; (dolist (local '(nil t))
+ ;; (setq tmp-name (tramp--test-make-temp-name local quoted))
+ ;; (should
+ ;; (zerop (process-file "echo" nil `(:file ,tmp-name) nil "foo")))
+ ;; (with-temp-buffer
+ ;; (insert-file-contents tmp-name)
+ ;; (should (string-equal "foo" (buffer-string)))
+ ;; (should-not (get-buffer-window (current-buffer) t))
+ ;; (delete-file tmp-name)))
+
+ ;; Check remote and local STDERR.
+ (dolist (local '(nil t))
+ (setq tmp-name (tramp--test-make-temp-name local quoted))
+ (should-not
+ (zerop
+ (process-file "cat" nil `(t ,tmp-name) nil "/does-not-exist")))
+ (with-temp-buffer
+ (insert-file-contents tmp-name)
+ (should
+ (string-match-p
+ "cat:.* No such file or directory" (buffer-string)))
+ (should-not (get-buffer-window (current-buffer) t))
+ (delete-file tmp-name))))
;; Cleanup.
+ (ignore-errors (kill-buffer buffer))
(ignore-errors (delete-file tmp-name))))))
;; Must be a command, because used as `sigusr1' handler.
@@ -6479,7 +6523,13 @@ This requires restrictions of file name syntax."
;; `default-directory' with special characters. See
;; Bug#53846.
(when (and (tramp--test-expensive-test-p)
- (tramp--test-supports-processes-p))
+ (tramp--test-supports-processes-p)
+ ;; Prior Emacs 27, `shell-file-name' was
+ ;; hard coded as "/bin/sh" for remote
+ ;; processes in Emacs. That doesn't work
+ ;; for tramp-adb.el.
+ (or (not (tramp--test-adb-p))
+ (tramp--test-emacs27-p)))
(let ((default-directory file1))
(dolist (this-shell-command
(append
@@ -7207,17 +7257,20 @@ Since it unloads Tramp, it shall be the last test to run."
(should (featurep 'tramp-archive))
;; This unloads also tramp-archive.el and tramp-theme.el if needed.
(unload-feature 'tramp 'force)
- ;; No Tramp feature must be left.
+
+ ;; No Tramp feature must be left except the test packages.
(should-not (featurep 'tramp))
(should-not (featurep 'tramp-archive))
(should-not (featurep 'tramp-theme))
(should-not
(all-completions
"tramp" (delq 'tramp-tests (delq 'tramp-archive-tests features))))
+
;; `file-name-handler-alist' must be clean.
(should-not (all-completions "tramp" (mapcar #'cdr file-name-handler-alist)))
+
;; There shouldn't be left a bound symbol, except buffer-local
- ;; variables, and autoload functions. We do not regard our test
+ ;; variables, and autoloaded functions. We do not regard our test
;; symbols, and the Tramp unload hooks.
(mapatoms
(lambda (x)
@@ -7231,6 +7284,7 @@ Since it unloads Tramp, it shall be the last test to run."
(not (string-match-p "unload-hook$" (symbol-name x)))
(not (get x 'tramp-autoload))
(ert-fail (format "`%s' still bound" x)))))
+
;; The defstruct `tramp-file-name' and all its internal functions
;; shall be purged.
(should-not (cl--find-class 'tramp-file-name))
@@ -7239,6 +7293,7 @@ Since it unloads Tramp, it shall be the last test to run."
(and (functionp x)
(string-match-p "tramp-file-name" (symbol-name x))
(ert-fail (format "Structure function `%s' still exists" x)))))
+
;; There shouldn't be left a hook function containing a Tramp
;; function. We do not regard the Tramp unload hooks.
(mapatoms
@@ -7248,7 +7303,18 @@ Since it unloads Tramp, it shall be the last test to run."
(not (string-match-p "unload-hook$" (symbol-name x)))
(consp (symbol-value x))
(ignore-errors (all-completions "tramp" (symbol-value x)))
- (ert-fail (format "Hook `%s' still contains Tramp function" x))))))
+ (ert-fail (format "Hook `%s' still contains Tramp function" x)))))
+
+ ;; There shouldn't be left an advice function from Tramp.
+ (mapatoms
+ (lambda (x)
+ (and (functionp x)
+ (advice-mapc
+ (lambda (fun _symbol)
+ (and (string-match-p "^tramp" (symbol-name fun))
+ (ert-fail
+ (format "Function `%s' still contains Tramp advice" x))))
+ x)))))
(defun tramp-test-all (&optional interactive)
"Run all tests for \\[tramp].
--
2.39.5