Github/emacs
2
0
Fork 1
mirror of git://git.sv.gnu.org/emacs.git synced 2026-02-16 17:24:23 +00:00
Code Issues Projects Releases Packages Wiki Activity

Jsonrpc: add new jsonrpc-autoport-bootstrap helper

Browse source 
This will help Eglot and some other extensions connect to network
servers that are started with a call to a local program.

* lisp/jsonrpc.el (jsonrpc--process-sentinel): Also delete inferior.
(jsonrpc-process-connection): Add -autoport-inferior slot.
(initialize-instance jsonrpc-process-connection): Check
process-creating function arity.  Use jsonrpc-forwarding-buffer
(jsonrpc-autoport-bootstrap): New helper.
(Version): Bump to 1.0.20.
This commit is contained in:
João Távora 2023-12-14 22:56:33 +00:00
parent af1fe69f05
commit 9e24cde227
1 changed files with 133 additions and 38 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

171
lisp/jsonrpc.el
View file

@ -4,7 +4,7 @@
;; Author: João Távora <joaotavora@gmail.com>
;; Keywords: processes, languages, extensions
;; Version: 1.0.19
;; Version: 1.0.20
;; Package-Requires: ((emacs "25.2"))
;; This is a GNU ELPA :core package. Avoid functionality that is not
@ -400,16 +400,20 @@ ignored."
:accessor jsonrpc--on-shutdown
:initform #'ignore
:initarg :on-shutdown
:documentation "Function run when the process dies."))
:documentation "Function run when the process dies.")
(-autoport-inferior
:initform nil
:documentation "Used by `jsonrpc-autoport-bootstrap'."))
:documentation "A JSONRPC connection over an Emacs process.
The following initargs are accepted:
:PROCESS (mandatory), a live running Emacs process object or a
function of no arguments producing one such object. The process
represents either a pipe connection to locally running process or
a stream connection to a network host. The remote endpoint is
expected to understand JSONRPC messages with basic HTTP-style
enveloping headers such as \"Content-Length:\".
function producing one such object. If a function, it is passed
the `jsonrpc-process-connection' object. The process represents
either a pipe connection to locally running process or a stream
connection to a network host. The remote endpoint is expected to
understand JSONRPC messages with basic HTTP-style enveloping
headers such as \"Content-Length:\".
:ON-SHUTDOWN (optional), a function of one argument, the
connection object, called when the process dies.")
@ -424,37 +428,22 @@ connection object, called when the process dies.")
;; could use a pipe with a process filter instead of
;; `after-change-functions'. Alternatively, we need a new initarg
;; (but maybe not a slot).
(let ((calling-buffer (current-buffer)))
(with-current-buffer (get-buffer-create (format "*%s stderr*" name))
(let ((inhibit-read-only t)
(hidden-name (concat " " (buffer-name))))
(erase-buffer)
(buffer-disable-undo)
(add-hook
'after-change-functions
(lambda (beg _end _pre-change-len)
(cl-loop initially (goto-char beg)
do (forward-line)
when (bolp)
for line = (buffer-substring
(line-beginning-position 0)
(line-end-position 0))
do (with-current-buffer (jsonrpc-events-buffer conn)
(goto-char (point-max))
(let ((inhibit-read-only t))
(insert (format "[stderr] %s\n" line))))
until (eobp)))
nil t)
;; If we are correctly coupled to the client, the process
;; now created should pick up the current stderr buffer,
;; which we immediately rename
(setq proc (if (functionp proc)
(with-current-buffer calling-buffer (funcall proc))
proc))
(ignore-errors (kill-buffer hidden-name))
(rename-buffer hidden-name)
(process-put proc 'jsonrpc-stderr (current-buffer))
(setq buffer-read-only t))))
(let* ((stderr-buffer-name (format "*%s stderr*" name))
(stderr-buffer (jsonrpc--forwarding-buffer stderr-buffer-name "[stderr]" conn))
(hidden-name (concat " " stderr-buffer-name)))
;; If we are correctly coupled to the client, the process now
;; created should pick up the `stderr-buffer' just created, which
;; we immediately rename
(setq proc (if (functionp proc)
(if (zerop (cdr (func-arity proc)))
(funcall proc)
(funcall proc conn))
proc))
(with-current-buffer stderr-buffer
(ignore-errors (kill-buffer hidden-name))
(rename-buffer hidden-name)
(setq buffer-read-only t))
(process-put proc 'jsonrpc-stderr stderr-buffer))
(setf (jsonrpc--process conn) proc)
(set-process-buffer proc (get-buffer-create (format " *%s output*" name)))
(set-process-filter proc #'jsonrpc--process-filter)
@ -601,6 +590,7 @@ With optional CLEANUP, kill any associated buffers."
(jsonrpc--request-continuations connection))
(jsonrpc--message "Server exited with status %s" (process-exit-status proc))
(delete-process proc)
(when-let (p (slot-value connection '-autoport-inferior)) (delete-process p))
(funcall (jsonrpc--on-shutdown connection) connection)))))
(cl-defun jsonrpc--process-filter (proc string)
@ -811,5 +801,110 @@ SUBTYPE tells more about the event."
(forward-line 2)
(point)))))))))))))
(defun jsonrpc--forwarding-buffer (name prefix conn)
"Helper for `jsonrpc-process-connection' helpers.
Make a stderr buffer named NAME, forwarding lines prefixed by
PREFIX to CONN's events buffer."
(with-current-buffer (get-buffer-create name)
(let ((inhibit-read-only t))
(fundamental-mode)
(erase-buffer)
(buffer-disable-undo)
(add-hook
'after-change-functions
(lambda (beg _end _pre-change-len)
(cl-loop initially (goto-char beg)
do (forward-line)
when (bolp)
for line = (buffer-substring
(line-beginning-position 0)
(line-end-position 0))
do (with-current-buffer (jsonrpc-events-buffer conn)
(goto-char (point-max))
(let ((inhibit-read-only t))
(insert (format "%s %s\n" prefix line))))
until (eobp)))
nil t))
(current-buffer)))
;;;; More convenience utils
(cl-defun jsonrpc-autoport-bootstrap (name contact
&key connect-args)
"Use CONTACT to start network server, then connect to it.
Return function suitable for the :PROCESS initarg of
`jsonrpc-process-connection' (which see).
CONTACT is a list where all the elements are strings except for
one, which is usuallky the keyword `:autoport'.
When the returned function is called it will start a program
using a command based on CONTACT, where `:autoport' is
substituted by a locally free network port. Thereafter, a
network is made to this port.
Instead of the keyword `:autoport', a cons cell (:autoport
FORMAT-FN) is also accepted. In that case FORMAT-FN is passed
the port number and should return a string used for the
substitution.
The internal processes and control buffers are named after NAME.
CONNECT-ARGS are passed as additional arguments to
`open-network-stream'."
(lambda (conn)
(let* ((port-probe (make-network-process :name "jsonrpc-port-probe-dummy"
:server t
:host "localhost"
:service 0))
(port-number (unwind-protect
(process-contact port-probe :service)
(delete-process port-probe)))
(inferior-buffer (jsonrpc--forwarding-buffer
(format " *%s inferior output*" name)
"[inferior]"
conn))
(cmd (cl-loop for e in contact
if (eq e :autoport) collect (format "%s" port-number)
else if (eq (car-safe e) :autoport)
collect (funcall (cdr e) port-number)
else collect e))
inferior np)
(unwind-protect
(progn
(message "[jsonrpc] Attempting to start `%s'"
(string-join cmd " "))
(setq inferior
(make-process
:name (format "inferior (%s)" name)
:buffer inferior-buffer
:noquery t
:command cmd))
(setq np
(cl-loop
repeat 10 for i from 0
do (accept-process-output nil 0.5)
while (process-live-p inferior)
do (message
"[jsonrpc] %sTrying to connect to localhost:%s (attempt %s)"
(if (zerop i) "Started. " "")
port-number (1+ i))
thereis (ignore-errors
(apply #'open-network-stream
(format "autostart (%s)" name)
nil
"localhost" port-number connect-args))))
(setf (slot-value conn '-autoport-inferior) inferior)
np)
(cond ((and (process-live-p np)
(process-live-p inferior))
(message "[jsonrpc] Done, connected to %s!" port-number))
(t
(when inferior (delete-process inferior))
(when np (delete-process np))
(error "[jsonrpc] Could not start and/or connect")))))))
(provide 'jsonrpc)
;;; jsonrpc.el ends here