diff --git a/emacs/gds-server.el b/emacs/gds-server.el index 86defc07b..2a11a1a93 100644 --- a/emacs/gds-server.el +++ b/emacs/gds-server.el @@ -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) diff --git a/emacs/gds.el b/emacs/gds.el index 1275d778b..01c9d97fe 100644 --- a/emacs/gds.el +++ b/emacs/gds.el @@ -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))) diff --git a/ice-9/gds-client.scm b/ice-9/gds-client.scm index 960015abd..3b6549e4c 100755 --- a/ice-9/gds-client.scm +++ b/ice-9/gds-client.scm @@ -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)))))) diff --git a/ice-9/gds-server.scm b/ice-9/gds-server.scm index f59758729..af30871f4 100644 --- a/ice-9/gds-server.scm +++ b/ice-9/gds-server.scm @@ -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))))))