[elpa] externals/eglot a2aa1ed 19/69: Robustify timer handling for jrpc-async-request

[João Távora]

branch: externals/eglot
commit a2aa1edd38176a470bf16e2c0211da1260422934
Author: João Távora <address@hidden>
Commit: João Távora <address@hidden>

    Robustify timer handling for jrpc-async-request
    
    * jrpc.el (jrpc-async-request): Improve timeout handling. Return a list (ID 
TIMER)
    (jrpc-request): Protect against user-quits, cancelling timer
---
 jrpc.el | 56 ++++++++++++++++++++++++++++++++++----------------------
 1 file changed, 34 insertions(+), 22 deletions(-)

diff --git a/jrpc.el b/jrpc.el
index 223a4ce..1d29023 100644
--- a/jrpc.el
+++ b/jrpc.el
@@ -531,12 +531,14 @@ identical DEFERRED and for the same buffer happens in the
 meantime.  However, in that situation, the original timeout is
 kept.
 
-Return the request ID, or nil, in case the request was deferred."
+Return a list (ID TIMER). ID is the new request's ID, or nil if
+the request was deferred. TIMER is a timer object set (or nil, if
+TIMEOUT is nil)"
   (let* ((id (jrpc--next-request-id))
-         (existing-timer nil)
-         (make-timeout
+         (timer nil)
+         (make-timer
           (lambda ( )
-            (or existing-timer
+            (or timer
                 (when timeout
                   (run-with-timer
                    timeout nil
@@ -550,7 +552,7 @@ Return the request ID, or nil, in case the request was 
deferred."
     (when deferred
       (let* ((buf (current-buffer))
              (existing (gethash (list deferred buf) (jrpc--deferred-actions 
proc))))
-        (when existing (setq existing-timer (cadr existing)))
+        (when existing (setq timer (cadr existing)))
         (if (run-hook-with-args-until-failure 'jrpc-ready-predicates
                                               deferred proc)
             (remhash (list deferred buf) (jrpc--deferred-actions proc))
@@ -562,9 +564,11 @@ Return the request ID, or nil, in case the request was 
deferred."
                               (save-excursion (goto-char point)
                                               (apply #'jrpc-async-request proc
                                                      method params args)))))))
-            (puthash (list deferred buf) (list later (funcall make-timeout))
+            (puthash (list deferred buf)
+                     (list later (setq timer (funcall make-timer)))
                      (jrpc--deferred-actions proc))
-            (cl-return-from jrpc-async-request nil)))))
+            ;; Non-local exit!
+            (cl-return-from jrpc-async-request (list nil timer))))))
     ;; Really send it
     ;;
     (jrpc--process-send proc (jrpc-obj :jsonrpc "2.0"
@@ -582,9 +586,9 @@ Return the request ID, or nil, in case the request was 
deferred."
                          (jrpc-log-event
                           proc (jrpc-obj :message "error ignored, status set"
                                          :id id :error code))))
-                   (funcall make-timeout))
+                   (setq timer (funcall make-timer)))
              (jrpc--request-continuations proc))
-    id))
+    (list id timer)))
 
 (cl-defun jrpc-request (proc method params &key deferred)
   "Make a request to PROC, wait for a reply.
@@ -596,21 +600,29 @@ request is successful, otherwise exit non-locally with an 
error.
 
 DEFERRED is passed to `jrpc-async-request', which see."
   (let* ((tag (cl-gensym "jrpc-request-catch-tag"))
+         req-id req-timer
          (retval
-          (catch tag
-            (jrpc-async-request
-             proc method params
-             :success-fn (lambda (result) (throw tag `(done ,result)))
-             :error-fn (jrpc-lambda (&key code message data)
-                         (throw tag `(error (jrpc-error-code . ,code)
-                                            (jrpc-error-message . ,message)
-                                            (jrpc-error-data . ,data))))
-             :timeout-fn (lambda ()
-                           (throw tag '(error (jrpc-error-message . "Timed 
out"))))
-             :deferred deferred)
-            (while t (accept-process-output nil 30)))))
+          (unwind-protect ; protect against user-quit, for example
+              (catch tag
+                (pcase-let
+                    ((`(,id ,timer)
+                      (jrpc-async-request
+                       proc method params
+                       :success-fn (lambda (result) (throw tag `(done 
,result)))
+                       :error-fn (jrpc-lambda (&key code message data)
+                                   (throw tag `(error (jrpc-error-code . ,code)
+                                                      (jrpc-error-message . 
,message)
+                                                      (jrpc-error-data . 
,data))))
+                       :timeout-fn (lambda ()
+                                     (throw tag '(error (jrpc-error-message . 
"Timed out"))))
+                       :deferred deferred)))
+                  (setq req-id (or id 'deferred) req-timer timer))
+                (while t (accept-process-output nil 30)))
+            (when req-timer (cancel-timer req-timer)))))
     (when (eq 'error (car retval))
-      (signal 'error (cons "[jrpc] jrpc-request failed:" (cdr retval))))
+      (signal 'error
+              (cons
+               (format "[jrpc] jrpc-request (%s) failed:" req-id) (cdr 
retval))))
     (cadr retval)))
 
 (cl-defun jrpc-notify (proc method params)