Github/emacs
2
0
Fork 1
mirror of git://git.sv.gnu.org/emacs.git synced 2026-02-17 10:27:41 +00:00
Code Issues Projects Releases Packages Wiki Activity

Improve Tramp's process-file implementations

Browse source 
* 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.
This commit is contained in:
Michael Albinus 2022-02-13 20:50:51 +01:00
parent fc44bc6255
commit bd07d4fac9
5 changed files with 153 additions and 40 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
lisp/net/tramp-adb.el
View file

@ -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")

4
lisp/net/tramp-sh.el
View file

@ -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)

2
lisp/net/tramp-smb.el
View file

@ -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))

55
lisp/net/tramp-sshfs.el
View file

@ -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.

126
test/lisp/net/tramp-tests.el
View file

@ -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.
(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))
;; 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))))
(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].