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).

diff --git a/lisp/url/url.el b/lisp/url/url.el
index 367af1b5a900ea8e92961de9c052655c74c7ac38..321e79c019f5642d97c1ad08e54dd447de094898 100644 (file)
--- 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.