Suspend timers when reading Tramp process output

* lisp/net/tramp-compat.el (xdg): Require.
(tramp-compat-temporary-file-directory): Set it to
$XDG_CACHE_HOME/emacs if possible.

* lisp/net/tramp.el (tramp-debug-to-file): Fix docstring.
(tramp-wrong-passwd-regexp): Add "Authentication failed" string
(from doas).
(tramp-debug-message): Simplify backtrace check.
(with-tramp-locked-connection): Suppress timers.  (Bug#49954, Bug60534)

* test/lisp/net/tramp-tests.el (tramp-test09-insert-file-contents):
Adapt test.
(tramp-test45-asynchronous-requests): Remove :unstable tag.
Adapt test.
This commit is contained in:
Michael Albinus 2023-05-04 20:42:24 +02:00
parent d3ec68f5e4
commit 5f79d821a0
4 changed files with 61 additions and 47 deletions

View file

@ -496,12 +496,12 @@ PROPERTIES is a list of file properties (strings)."
(cons property (gethash property hash tramp-cache-undefined))) (cons property (gethash property hash tramp-cache-undefined)))
,properties))) ,properties)))
(unwind-protect (progn ,@body) (unwind-protect (progn ,@body)
;; Reset PROPERTIES. Recompute hash, it could have been flushed. ;; Reset PROPERTIES. Recompute hash, it could have been flushed.
(setq hash (tramp-get-hash-table ,key)) (setq hash (tramp-get-hash-table ,key))
(dolist (value values) (dolist (value values)
(if (not (eq (cdr value) tramp-cache-undefined)) (if (not (eq (cdr value) tramp-cache-undefined))
(puthash (car value) (cdr value) hash) (puthash (car value) (cdr value) hash)
(remhash (car value) hash))))))) (remhash (car value) hash)))))))
;;;###tramp-autoload ;;;###tramp-autoload
(defun tramp-cache-print (table) (defun tramp-cache-print (table)

View file

@ -35,6 +35,7 @@
(require 'parse-time) (require 'parse-time)
(require 'shell) (require 'shell)
(require 'subr-x) (require 'subr-x)
(require 'xdg)
(declare-function tramp-error "tramp") (declare-function tramp-error "tramp")
(declare-function tramp-tramp-file-p "tramp") (declare-function tramp-tramp-file-p "tramp")
@ -64,9 +65,16 @@
(with-no-warnings (funcall ,function ,@arguments)))) (with-no-warnings (funcall ,function ,@arguments))))
;; We must use a local directory. If it is remote, we could run into ;; We must use a local directory. If it is remote, we could run into
;; an infloop. ;; an infloop. We try to follow the XDG specification, for security reasons.
(defconst tramp-compat-temporary-file-directory (defconst tramp-compat-temporary-file-directory
(eval (car (get 'temporary-file-directory 'standard-value)) t) (file-name-as-directory
(if-let ((xdg (xdg-cache-home))
((file-directory-p xdg))
((file-writable-p xdg)))
;; We can use `file-name-concat' starting with Emacs 28.1.
(prog1 (setq xdg (concat (file-name-as-directory xdg) "emacs"))
(make-directory xdg t))
(eval (car (get 'temporary-file-directory 'standard-value)) t)))
"The default value of `temporary-file-directory'.") "The default value of `temporary-file-directory'.")
(defsubst tramp-compat-make-temp-name () (defsubst tramp-compat-make-temp-name ()

View file

@ -120,7 +120,7 @@ Any level x includes messages for all levels 1 .. x-1. The levels are
(defcustom tramp-debug-to-file nil (defcustom tramp-debug-to-file nil
"Whether Tramp debug messages shall be saved to file. "Whether Tramp debug messages shall be saved to file.
The debug file has the same name as the debug buffer, written to The debug file has the same name as the debug buffer, written to
`temporary-file-directory'." `tramp-compat-temporary-file-directory'."
:version "28.1" :version "28.1"
:type 'boolean) :type 'boolean)
@ -665,6 +665,7 @@ The `sudo' program appears to insert a `^@' character into the prompt."
"Sorry, try again." "Sorry, try again."
"Name or service not known" "Name or service not known"
"Host key verification failed." "Host key verification failed."
"Authentication failed"
"No supported authentication methods left to try!" "No supported authentication methods left to try!"
(: "Login " (| "Incorrect" "incorrect")) (: "Login " (| "Incorrect" "incorrect"))
(: "Connection " (| "refused" "closed")) (: "Connection " (| "refused" "closed"))
@ -1970,7 +1971,7 @@ of `current-buffer'."
(+ digit) ":" (+ digit) ":" (+ digit) "." (+ digit) blank (+ digit) ":" (+ digit) ":" (+ digit) "." (+ digit) blank
;; Thread. ;; Thread.
(? (group "#<thread " (+ nonl) ">") blank) (? (group "#<thread " (+ nonl) ">") blank)
;; Function name, verbosity. ;; Function name, verbosity.
(+ (any "-" alnum)) " (" (group (+ digit)) ") #") (+ (any "-" alnum)) " (" (group (+ digit)) ") #")
"Used for highlighting Tramp debug buffers in `outline-mode'.") "Used for highlighting Tramp debug buffers in `outline-mode'.")
@ -2109,18 +2110,23 @@ ARGUMENTS to actually emit the message (if applicable)."
(insert "\n")) (insert "\n"))
;; Timestamp. ;; Timestamp.
(insert (format-time-string "%T.%6N ")) (insert (format-time-string "%T.%6N "))
;; Threads. `current-thread' might not exist when Emacs is
;; configured --without-threads.
;; (unless (eq (tramp-compat-funcall 'current-thread) main-thread)
;; (insert (format "%s " (tramp-compat-funcall 'current-thread))))
;; Calling Tramp function. We suppress compat and trace ;; Calling Tramp function. We suppress compat and trace
;; functions from being displayed. ;; functions from being displayed.
(let ((btn 1) btf fn) (let ((frames (backtrace-frames))
btf fn)
(while (not fn) (while (not fn)
(setq btf (nth 1 (backtrace-frame btn))) (setq btf (cadadr frames))
(if (not btf) (if (not btf)
(setq fn "") (setq fn "")
(and (symbolp btf) (setq fn (symbol-name btf)) (and (symbolp btf) (setq fn (symbol-name btf))
(or (not (string-prefix-p "tramp" fn)) (or (not (string-prefix-p "tramp" fn))
(get btf 'tramp-suppress-trace)) (get btf 'tramp-suppress-trace))
(setq fn nil)) (setq fn nil))
(setq btn (1+ btn)))) (setq frames (cdr frames))))
;; The following code inserts filename and line number. ;; The following code inserts filename and line number.
;; Should be inactive by default, because it is time consuming. ;; Should be inactive by default, because it is time consuming.
;; (let ((ffn (find-function-noselect (intern fn)))) ;; (let ((ffn (find-function-noselect (intern fn))))
@ -3790,14 +3796,14 @@ BODY is the backend specific code."
;; VISIT, for example `jka-compr-handler'. We must respect this. ;; VISIT, for example `jka-compr-handler'. We must respect this.
;; See Bug#55166. ;; See Bug#55166.
`(let* ((filename (expand-file-name ,filename)) `(let* ((filename (expand-file-name ,filename))
(lockname (file-truename (or ,lockname filename))) (lockname (file-truename (or ,lockname filename)))
(handler (and (stringp ,visit) (handler (and (stringp ,visit)
(let ((inhibit-file-name-handlers (let ((inhibit-file-name-handlers
`(tramp-file-name-handler `(tramp-file-name-handler
tramp-crypt-file-name-handler tramp-crypt-file-name-handler
. inhibit-file-name-handlers)) . inhibit-file-name-handlers))
(inhibit-file-name-operation 'write-region)) (inhibit-file-name-operation 'write-region))
(find-file-name-handler ,visit 'write-region))))) (find-file-name-handler ,visit 'write-region)))))
(with-parsed-tramp-file-name filename nil (with-parsed-tramp-file-name filename nil
(if handler (if handler
(progn (progn
@ -5821,11 +5827,14 @@ Mostly useful to protect BODY from being interrupted by timers."
(throw 'non-essential 'non-essential) (throw 'non-essential 'non-essential)
(tramp-error (tramp-error
,proc 'remote-file-error "Forbidden reentrant call of Tramp")) ,proc 'remote-file-error "Forbidden reentrant call of Tramp"))
(unwind-protect (let ((stimers (with-timeout-suspend))
(progn timer-list timer-idle-list)
(tramp-set-connection-property ,proc "locked" t) (unwind-protect
,@body) (progn
(tramp-flush-connection-property ,proc "locked")))) (tramp-set-connection-property ,proc "locked" t)
,@body)
(tramp-flush-connection-property ,proc "locked")
(with-timeout-unsuspend stimers)))))
(defun tramp-accept-process-output (proc &optional _timeout) (defun tramp-accept-process-output (proc &optional _timeout)
"Like `accept-process-output' for Tramp processes. "Like `accept-process-output' for Tramp processes.

View file

@ -2440,15 +2440,19 @@ This checks also `file-name-as-directory', `file-name-directory',
`(,(expand-file-name tmp-name) 0))) `(,(expand-file-name tmp-name) 0)))
(should (string-equal (buffer-string) "foo")) (should (string-equal (buffer-string) "foo"))
(should (= point (point)))) (should (= point (point))))
(let ((point (point))) ;; Insert another string.
(replace-string-in-region "foo" "bar" (point-min) (point-max)) ;; `replace-string-in-region' was introduced in Emacs 28.1.
(goto-char point) (when (tramp--test-emacs28-p)
(should (let ((point (point)))
(equal (with-no-warnings
(insert-file-contents tmp-name nil nil nil 'replace) (replace-string-in-region "foo" "bar" (point-min) (point-max)))
`(,(expand-file-name tmp-name) 3))) (goto-char point)
(should (string-equal (buffer-string) "foo")) (should
(should (= point (point)))) (equal
(insert-file-contents tmp-name nil nil nil 'replace)
`(,(expand-file-name tmp-name) 3)))
(should (string-equal (buffer-string) "foo"))
(should (= point (point)))))
;; Error case. ;; Error case.
(delete-file tmp-name) (delete-file tmp-name)
(should-error (should-error
@ -7444,12 +7448,7 @@ This is needed in timer functions as well as process filters and sentinels."
"Check parallel asynchronous requests. "Check parallel asynchronous requests.
Such requests could arrive from timers, process filters and Such requests could arrive from timers, process filters and
process sentinels. They shall not disturb each other." process sentinels. They shall not disturb each other."
;; :tags (append '(:expensive-test :tramp-asynchronous-processes) :tags '(:expensive-test :tramp-asynchronous-processes)
;; (and (or (getenv "EMACS_HYDRA_CI")
;; (getenv "EMACS_EMBA_CI"))
;; '(:unstable)))
;; It doesn't work sufficiently.
:tags '(:expensive-test :tramp-asynchronous-processes :unstable)
(skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-enabled))
(skip-unless (tramp--test-supports-processes-p)) (skip-unless (tramp--test-supports-processes-p))
(skip-unless (not (tramp--test-container-p))) (skip-unless (not (tramp--test-container-p)))
@ -7517,14 +7516,12 @@ process sentinels. They shall not disturb each other."
(when buffers (when buffers
(let ((time (float-time)) (let ((time (float-time))
(default-directory tmp-name) (default-directory tmp-name)
(file (buffer-name (seq-random-elt buffers))) (file (buffer-name (seq-random-elt buffers))))
;; A remote operation in a timer could
;; confuse Tramp heavily. So we ignore this
;; error here.
(debug-ignored-errors
(cons 'remote-file-error debug-ignored-errors)))
(tramp--test-message (tramp--test-message
"Start timer %s %s" file (current-time-string)) "Start timer %s %s" file (current-time-string))
(dired-uncache file)
(tramp--test-message
"Continue timer %s %s" file (file-attributes file))
(vc-registered file) (vc-registered file)
(tramp--test-message (tramp--test-message
"Stop timer %s %s" file (current-time-string)) "Stop timer %s %s" file (current-time-string))