forked from Github/emacs
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:
parent
d3ec68f5e4
commit
5f79d821a0
4 changed files with 61 additions and 47 deletions
|
|
@ -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)
|
||||||
|
|
|
||||||
|
|
@ -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 ()
|
||||||
|
|
|
||||||
|
|
@ -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.
|
||||||
|
|
|
||||||
|
|
@ -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))
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue