master 7a24cff: Only kill url-retrieve-synchronously connections when we have a timeout

[Lars Ingebrigtsen]

branch: master
commit 7a24cff1b2be9068a7c578360f6b51236105d98b
Author: Lars Ingebrigtsen <larsi@gnus.org>
Commit: Lars Ingebrigtsen <larsi@gnus.org>

    Only kill url-retrieve-synchronously connections when we have a timeout
    
    * lisp/url/url.el (url-retrieve-synchronously): Only kill the
    connections when we have a timeout (bug#34607).
---
 lisp/url/url.el | 18 +++++++++++-------
 1 file changed, 11 insertions(+), 7 deletions(-)

diff --git a/lisp/url/url.el b/lisp/url/url.el
index 367af1b..321e79c 100644
--- a/lisp/url/url.el
+++ b/lisp/url/url.el
@@ -238,7 +238,8 @@ how long to wait for a response before giving up."
   (let ((retrieval-done nil)
        (start-time (current-time))
         (url-asynchronous nil)
-        (asynch-buffer nil))
+        (asynch-buffer nil)
+        (timed-out nil))
     (setq asynch-buffer
          (url-retrieve url (lambda (&rest ignored)
                              (url-debug 'retrieval "Synchronous fetching done 
(%S)" (current-buffer))
@@ -261,7 +262,9 @@ how long to wait for a response before giving up."
        ;; process output.
        (while (and (not retrieval-done)
                     (or (not timeout)
-                       (time-less-p (time-since start-time) timeout)))
+                       (not (setq timed-out
+                                   (time-less-p timeout
+                                                (time-since start-time))))))
          (url-debug 'retrieval
                     "Spinning in url-retrieve-synchronously: %S (%S)"
                     retrieval-done asynch-buffer)
@@ -303,11 +306,12 @@ how long to wait for a response before giving up."
                              (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 (process-live-p proc)
-          (delete-process proc))
-        (when-let ((aproc (get-buffer-process asynch-buffer)))
-          (when (process-live-p aproc)
-            (delete-process aproc)))))
+        (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.