(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)
(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) "")
?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.
(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
(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))
(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.
;; `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
(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)
(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))
(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
(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].
projects / emacs.git / commitdiff