mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-17 19:30:38 -08:00
Code Issues Projects Releases Wiki Activity

Fix problem with occasional stalls in `url-retrieve-synchronously'

Browse source 
* lisp/url/url.el (url-retrieve-synchronously): Use
`accept-process-output' on a null process.  That is the safer, more
conventional way of achieving non-blocking sleep-for (bug#49897).

Also rewrite for greater readability.
This commit is contained in:
dick r. chiang 2021-08-06 13:24:53 +02:00 • committed by Lars Ingebrigtsen
parent b17fd982a3
commit 93e1248c20
1 changed files with 49 additions and 79 deletions
Download patch file Download diff file Expand all files Collapse all files

128
lisp/url/url.el
View file

@ -235,85 +235,55 @@ If INHIBIT-COOKIES is non-nil, refuse to store cookies. If
TIMEOUT is passed, it should be a number that says (in seconds) TIMEOUT is passed, it should be a number that says (in seconds)
how long to wait for a response before giving up." how long to wait for a response before giving up."
(url-do-setup) (url-do-setup)
(let* (url-asynchronous
(let ((retrieval-done nil) data-buffer
(start-time (current-time)) (callback (lambda (&rest _args)
(url-asynchronous nil) (setq data-buffer (current-buffer))
(asynch-buffer nil) (url-debug 'retrieval
(timed-out nil)) "Synchronous fetching done (%S)"
(setq asynch-buffer data-buffer)))
(url-retrieve url (lambda (&rest ignored) (start-time (current-time))
(url-debug 'retrieval "Synchronous fetching done (%S)" (current-buffer)) (proc-buffer (url-retrieve url callback nil silent
(setq retrieval-done t inhibit-cookies)))
asynch-buffer (current-buffer))) (if (not proc-buffer)
nil silent inhibit-cookies)) (url-debug 'retrieval "Synchronous fetching unnecessary %s" url)
(if (null asynch-buffer) (unwind-protect
;; We do not need to do anything, it was a mailto or something (catch 'done
;; similar that takes processing completely outside of the URL (while (not data-buffer)
;; package. (when (and timeout (time-less-p timeout
nil (time-since start-time)))
(let ((proc (get-buffer-process asynch-buffer))) (url-debug 'retrieval "Timed out %s (after %ss)" url
;; If the access method was synchronous, `retrieval-done' should (float-time (time-since start-time)))
;; hopefully already be set to t. If it is nil, and `proc' is also (throw 'done 'timeout))
;; nil, it implies that the async process is not running in (url-debug 'retrieval
;; asynch-buffer. This happens e.g. for FTP files. In such a case "Spinning in url-retrieve-synchronously: nil (%S)"
;; url-file.el should probably set something like a `url-process' proc-buffer)
;; buffer-local variable so we can find the exact process that we (when-let ((redirect-buffer
;; should be waiting for. In the mean time, we'll just wait for any (buffer-local-value 'url-redirect-buffer
;; process output. proc-buffer)))
(while (and (not retrieval-done) (unless (eq redirect-buffer proc-buffer)
(or (not timeout) (url-debug
(not (setq timed-out 'retrieval "Redirect in url-retrieve-synchronously: %S -> %S"
(time-less-p timeout proc-buffer redirect-buffer)
(time-since start-time)))))) (let (kill-buffer-query-functions)
(url-debug 'retrieval (kill-buffer proc-buffer))
"Spinning in url-retrieve-synchronously: %S (%S)" ;; Accommodate hack in commit 55d1d8b.
retrieval-done asynch-buffer) (setq proc-buffer redirect-buffer)))
(if (buffer-local-value 'url-redirect-buffer asynch-buffer) (when-let ((proc (get-buffer-process proc-buffer)))
(setq proc (get-buffer-process (when (memq (process-status proc)
(setq asynch-buffer '(closed exit signal failed))
(buffer-local-value 'url-redirect-buffer ;; Process sentinel vagaries occasionally cause
asynch-buffer)))) ;; url-retrieve to fail calling callback.
(if (and proc (memq (process-status proc) (unless data-buffer
'(closed exit signal failed)) (url-debug 'retrieval "Dead process %s" url)
;; Make sure another process hasn't been started. (throw 'done 'exception))))
(eq proc (or (get-buffer-process asynch-buffer) proc))) ;; Querying over consumer internet in the US takes 100
;; FIXME: It's not clear whether url-retrieve's callback is ;; ms, so split the difference.
;; guaranteed to be called or not. It seems that url-http (accept-process-output nil 0.05)))
;; decides sometimes consciously not to call it, so it's not (unless (eq data-buffer proc-buffer)
;; clear that it's a bug, but even then we need to decide how (let (kill-buffer-query-functions)
;; url-http can then warn us that the download has completed. (kill-buffer proc-buffer)))))
;; In the mean time, we use this here workaround. data-buffer))
;; XXX: The callback must always be called. Any
;; exception is a bug that should be fixed, not worked
;; around.
(progn ;; Call delete-process so we run any sentinel now.
(delete-process proc)
(setq retrieval-done t)))
;; We used to use `sit-for' here, but in some cases it wouldn't
;; work because apparently pending keyboard input would always
;; interrupt it before it got a chance to handle process input.
;; `sleep-for' was tried but it lead to other forms of
;; hanging. --Stef
(unless (or (with-local-quit
(accept-process-output proc 1))
(null proc))
;; accept-process-output returned nil, maybe because the process
;; exited (and may have been replaced with another). If we got
;; a quit, just stop.
(when quit-flag
(delete-process proc))
(setq proc (and (not quit-flag)
(get-buffer-process asynch-buffer))))))
;; On timeouts, make sure we kill any pending processes.
;; There may be more than one if we had a redirect.
(when timed-out
(when (process-live-p proc)
(delete-process proc))
(when-let ((aproc (get-buffer-process asynch-buffer)))
(when (process-live-p aproc)
(delete-process aproc))))))
asynch-buffer))
;; url-mm-callback called from url-mm, which requires mm-decode. ;; url-mm-callback called from url-mm, which requires mm-decode.
(declare-function mm-dissect-buffer "mm-decode" (declare-function mm-dissect-buffer "mm-decode"