diff options
Diffstat (limited to 'lisp/jsonrpc.el')
| -rw-r--r-- | lisp/jsonrpc.el | 67 |
1 files changed, 46 insertions, 21 deletions
diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index 3f33443f321..5037d8c5b2b 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -4,7 +4,7 @@ ;; Author: João Távora <joaotavora@gmail.com> ;; Keywords: processes, languages, extensions -;; Version: 1.0.23 +;; Version: 1.0.25 ;; Package-Requires: ((emacs "25.2")) ;; This is a GNU ELPA :core package. Avoid functionality that is not @@ -438,7 +438,7 @@ ignored." `(canceled ,cancel-on-input-retval)) (t (while t (accept-process-output nil 30))))) ;; In normal operation, continuations for error/success is - ;; handled by `jsonrpc-continue'. Timeouts also remove + ;; handled by `jsonrpc--continue'. Timeouts also remove ;; the continuation... (pcase-let* ((`(,id ,_) id-and-timer)) ;; ...but we still have to guard against exist explicit @@ -689,8 +689,22 @@ With optional CLEANUP, kill any associated buffers." (when-let (p (slot-value connection '-autoport-inferior)) (delete-process p)) (funcall (jsonrpc--on-shutdown connection) connection))))) +(defvar jsonrpc--in-process-filter nil + "Non-nil if inside `jsonrpc--process-filter'.") + (cl-defun jsonrpc--process-filter (proc string) "Called when new data STRING has arrived for PROC." + (when jsonrpc--in-process-filter + ;; Problematic recursive process filters may happen if + ;; `jsonrpc-connection-receive', called by us, eventually calls + ;; client code which calls `process-send-string' (which see) to, + ;; say send a follow-up message. If that happens to writes enough + ;; bytes for pending output to be received, we will lose JSONRPC + ;; messages. In that case, remove recursiveness by re-scheduling + ;; ourselves to run from within a timer as soon as possible + ;; (bug#60088) + (run-at-time 0 nil #'jsonrpc--process-filter proc string) + (cl-return-from jsonrpc--process-filter)) (when (buffer-live-p (process-buffer proc)) (with-current-buffer (process-buffer proc) (let* ((conn (process-get proc 'jsonrpc-connection)) @@ -746,10 +760,11 @@ With optional CLEANUP, kill any associated buffers." (setq message (plist-put message :jsonrpc-json (buffer-string))) - (process-put proc 'jsonrpc-mqueue - (nconc (process-get proc - 'jsonrpc-mqueue) - (list message))))) + ;; Put new messages at the front of the queue, + ;; this is correct as the order is reversed + ;; before putting the timers on `timer-list'. + (push message + (process-get proc 'jsonrpc-mqueue)))) (goto-char message-end) (let ((inhibit-read-only t)) (delete-region (point-min) (point))) @@ -768,11 +783,20 @@ With optional CLEANUP, kill any associated buffers." ;; non-locally (typically the reply to a request), so do ;; this all this processing in top-level loops timer. (cl-loop + ;; `timer-activate' orders timers by time, which is an + ;; very expensive operation when jsonrpc-mqueue is large, + ;; therefore the time object is reused for each timer + ;; created. + with time = (current-time) for msg = (pop (process-get proc 'jsonrpc-mqueue)) while msg - do (run-at-time 0 nil - (lambda (m) (with-temp-buffer - (jsonrpc-connection-receive conn m))) - msg))))))) + do (let ((timer (timer-create))) + (timer-set-time timer time) + (timer-set-function timer + (lambda (conn msg) + (with-temp-buffer + (jsonrpc-connection-receive conn msg))) + (list conn msg)) + (timer-activate timer)))))))) (defun jsonrpc--remove (conn id &optional deferred-spec) "Cancel CONN's continuations for ID, including its timer, if it exists. @@ -782,7 +806,7 @@ Return the full continuation (ID SUCCESS-FN ERROR-FN TIMER)" (if deferred-spec (remhash deferred-spec defs)) (when-let ((ass (assq id conts))) (cl-destructuring-bind (_ _ _ _ timer) ass - (cancel-timer timer)) + (when timer (cancel-timer timer))) (setf conts (delete ass conts)) ass))) @@ -1003,16 +1027,17 @@ of the API instead.") (or method "") (if id (format "[%s]" id) ""))))) (msg - (cond ((eq format 'full) - (format "%s%s\n" preamble (or json log-text))) - ((eq format 'short) - (format "%s%s\n" preamble (or log-text ""))) - (t - (format "%s%s" preamble - (or (and foreign-message - (concat "\n" (pp-to-string - foreign-message))) - (concat log-text "\n"))))))) + (pcase format + ('full (format "%s%s\n" preamble (or json log-text))) + ('short (format "%s%s\n" preamble (or log-text ""))) + (_ + (format "%s%s" preamble + (or (and foreign-message + (let ((lisp-indent-function ;bug#68072 + #'lisp-indent-function)) + (concat "\n" (pp-to-string + foreign-message)))) + (concat log-text "\n"))))))) (goto-char (point-max)) ;; XXX: could use `run-at-time' to delay server logs ;; slightly to play nice with verbose servers' stderr. |