mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Support multiple concurrent instances of Emacs + GDS server

Browse source 
By:

- Making the Unix socket name unique (for each Emacs instance), by
  appending Emacs's PID to it.

- Changing the GDS server to listen on both Unix domain and TCP (and
  not to mind if the TCP bind fails, which will happen if another GDS
  instance has already bound to the TCP port number).

- Adding this unique Unix socket name to the environment (as
  GDS_UNIX_SOCKET_NAME), so that Guile clients started from inside
  Emacs can pick it up.

- Changing the GDS client code to look for GDS_UNIX_SOCKET_NAME in the
  environment, and to connect to the Unix socket with that name
  instead of over TCP.

  Guile clients started outside Emacs will not find
  GDS_UNIX_SOCKET_NAME and so will fall back to using TCP.  This means
  they will connect to whichever Emacs + GDS server instance started
  first.

* emacs/gds-server.el (gds-start-server): Take both Unix socket name
  and TCP port args, instead of just one (which could be either Unix
  or TCP), and pass these on to `run-server'.  Remove unused optional
  bufname arg.

* emacs/gds.el (gds-unix-socket-name, gds-tcp-port): New variables.
  (gds-socket-type-alist): Removed.
  (gds-run-debug-server): Pass gds-unix-socket-name and gds-tcp-port
  to gds-start-server.  Add the Unix socket name to the environment.
  (gds-server-socket-type): Note now obsolete.

* ice-9/gds-client.scm (connect-to-gds): Get Unix socket name from
  environment, and connect to this in preference to using TCP.

* ice-9/gds-server.scm (run-server): Take both Unix socket name and
  TCP port args.  Listen and accept connections on both.
This commit is contained in:
Neil Jerram 2008-12-12 23:59:21 +00:00
parent a9408365f9
commit 72553cb0ce
4 changed files with 56 additions and 60 deletions
Download patch file Download diff file Expand all files Collapse all files

19
emacs/gds-server.el
View file

@ -44,25 +44,24 @@
:group 'gds
:type '(choice (const :tag "nil" nil) directory))
(defun gds-start-server (procname port-or-path protocol-handler &optional bufname)
"Start a GDS server process called PROCNAME, listening on TCP port
or Unix domain socket PORT-OR-PATH. PROTOCOL-HANDLER should be a
function that accepts and processes one protocol form. Optional arg
BUFNAME specifies the name of the buffer that is used for process
output; if not specified the buffer name is the same as the process
name."
(with-current-buffer (get-buffer-create (or bufname procname))
(defun gds-start-server (procname unix-socket-name tcp-port protocol-handler)
"Start a GDS server process called PROCNAME, listening on Unix
domain socket UNIX-SOCKET-NAME and TCP port number TCP-PORT.
PROTOCOL-HANDLER should be a function that accepts and processes
one protocol form."
(with-current-buffer (get-buffer-create procname)
(erase-buffer)
(let* ((code (format "(begin
%s
(use-modules (ice-9 gds-server))
(run-server %S))"
(run-server %S %S))"
(if gds-scheme-directory
(concat "(set! %load-path (cons "
(format "%S" gds-scheme-directory)
" %load-path))")
"")
port-or-path))
unix-socket-name
tcp-port))
(process-connection-type nil) ; use a pipe
(proc (start-process procname
(current-buffer)

21
emacs/gds.el
View file

@ -37,10 +37,11 @@
;; The subprocess object for the debug server.
(defvar gds-debug-server nil)
(defvar gds-socket-type-alist '((tcp . 8333)
(unix . "/tmp/.gds_socket"))
"Maps each of the possible socket types that the GDS server can
listen on to the path that it should bind to for each one.")
(defvar gds-unix-socket-name (format "/tmp/.gds-socket-%d" (emacs-pid))
"Name of the Unix domain socket that GDS will listen on.")
(defvar gds-tcp-port 8333
"The TCP port number that GDS will listen on.")
(defun gds-run-debug-server ()
"Start (or restart, if already running) the GDS debug server process."
@ -48,10 +49,14 @@ listen on to the path that it should bind to for each one.")
(if gds-debug-server (gds-kill-debug-server))
(setq gds-debug-server
(gds-start-server "gds-debug"
(cdr (assq gds-server-socket-type
gds-socket-type-alist))
gds-unix-socket-name
gds-tcp-port
'gds-debug-protocol))
(process-kill-without-query gds-debug-server))
(process-kill-without-query gds-debug-server)
;; Add the Unix socket name to the environment, so that Guile
;; clients started from within this Emacs will be able to use it,
;; and thereby ensure that they connect to the GDS in this Emacs.
(setenv "GDS_UNIX_SOCKET_NAME" gds-unix-socket-name))
(defun gds-kill-debug-server ()
"Kill the GDS debug server process."
@ -617,7 +622,7 @@ you would add an element to this alist to transform
:group 'gds)
(defcustom gds-server-socket-type 'tcp
"What kind of socket the GDS server should listen on."
"This option is now obsolete and has no effect."
:group 'gds
:type '(choice (const :tag "TCP" tcp)
(const :tag "Unix" unix)))

29
ice-9/gds-client.scm
View file

@ -172,23 +172,20 @@
(define (connect-to-gds . application-name)
(or gds-port
(begin
(let ((gds-unix-socket-name (getenv "GDS_UNIX_SOCKET_NAME")))
(set! gds-port
(or (let ((s (socket PF_INET SOCK_STREAM 0))
(SOL_TCP 6)
(TCP_NODELAY 1))
(setsockopt s SOL_TCP TCP_NODELAY 1)
(catch #t
(lambda ()
(connect s AF_INET (inet-aton "127.0.0.1") 8333)
s)
(lambda _ #f)))
(let ((s (socket PF_UNIX SOCK_STREAM 0)))
(catch #t
(lambda ()
(connect s AF_UNIX "/tmp/.gds_socket")
s)
(lambda _ #f)))
(or (and gds-unix-socket-name
(false-if-exception
(let ((s (socket PF_UNIX SOCK_STREAM 0)))
(connect s AF_UNIX gds-unix-socket-name)
s)))
(false-if-exception
(let ((s (socket PF_INET SOCK_STREAM 0))
(SOL_TCP 6)
(TCP_NODELAY 1))
(setsockopt s SOL_TCP TCP_NODELAY 1)
(connect s AF_INET (inet-aton "127.0.0.1") 8333)
s))
(error "Couldn't connect to GDS by TCP or Unix domain socket")))
(write-form (list 'name (getpid) (apply client-name application-name))))))

47
ice-9/gds-server.scm
View file

@ -36,38 +36,31 @@
(define connection->id (make-object-property))
(define (run-server port-or-path)
(define (run-server unix-socket-name tcp-port)
(or (integer? port-or-path)
(string? port-or-path)
(error "port-or-path should be an integer (port number) or a string (file name)"
port-or-path))
(let ((unix-server (socket PF_UNIX SOCK_STREAM 0))
(tcp-server (socket PF_INET SOCK_STREAM 0)))
(let ((server (socket (if (integer? port-or-path) PF_INET PF_UNIX)
SOCK_STREAM
0)))
;; Bind and start listening on the Unix domain socket.
(false-if-exception (delete-file unix-socket-name))
(bind unix-server AF_UNIX unix-socket-name)
(listen unix-server 5)
;; Initialize server socket.
(if (integer? port-or-path)
(begin
(setsockopt server SOL_SOCKET SO_REUSEADDR 1)
(bind server AF_INET INADDR_ANY port-or-path))
(begin
(catch #t
(lambda () (delete-file port-or-path))
(lambda _ #f))
(bind server AF_UNIX port-or-path)))
;; Start listening.
(listen server 5)
;; Bind and start listening on the TCP socket.
(setsockopt tcp-server SOL_SOCKET SO_REUSEADDR 1)
(false-if-exception (bind tcp-server AF_INET INADDR_ANY tcp-port))
(listen tcp-server 5)
;; Main loop.
(let loop ((clients '()) (readable-sockets '()))
(define (do-read port)
(cond ((eq? port (current-input-port))
(do-read-from-ui))
((eq? port server)
(accept-new-client))
((eq? port unix-server)
(accept-new-client unix-server))
((eq? port tcp-server)
(accept-new-client tcp-server))
(else
(do-read-from-client port))))
@ -86,7 +79,7 @@
(trc "client not found")))
clients)
(define (accept-new-client)
(define (accept-new-client server)
(let ((new-port (car (accept server))))
;; Read the client's ID.
(let ((name-form (read new-port)))
@ -122,8 +115,10 @@
;;(trc 'readable-sockets readable-sockets)
(if (null? readable-sockets)
(loop clients (car (select (cons (current-input-port)
(cons server clients))
(loop clients (car (select (cons* (current-input-port)
unix-server
tcp-server
clients)
'()
'())))
(loop (do-read (car readable-sockets)) (cdr readable-sockets))))))