emacs/gds-server.scm

   1 ;;;; Guile Debugger UI server
   2
   3 ;;; Copyright (C) 2003 Free Software Foundation, Inc.
   4 ;;;
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 2.1 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  18
  19 (define-module (emacs gds-server)
  20   #:use-module (emacs gds-client)
  21   #:export (run-server))
  22
  23 ;; UI is normally via a pipe to Emacs, so make sure to flush output
  24 ;; every time we write.
  25 (define (write-to-ui form)
  26   (write form)
  27   (newline)
  28   (force-output))
  29
  30 (define (trc . args)
  31   (write-to-ui (cons '* args)))
  32
  33 (define (with-error->eof proc port)
  34   (catch #t
  35          (lambda () (proc port))
  36          (lambda args the-eof-object)))
  37
  38 (define (run-server . ignored-args)
  39
  40   (let ((server (socket PF_INET SOCK_STREAM 0)))
  41
  42     ;; Initialize server socket.
  43     (setsockopt server SOL_SOCKET SO_REUSEADDR 1)
  44     (bind server AF_INET INADDR_ANY gds-port-number)
  45     (listen server 5)
  46
  47     (let loop ((clients '()) (readable-sockets '()))
  48
  49       (define (do-read port)
  50         (cond ((eq? port (current-input-port))
  51                (do-read-from-ui))
  52               ((eq? port server)
  53                (accept-new-client))
  54               (else
  55                (do-read-from-client port))))
  56
  57       (define (do-read-from-ui)
  58         (trc "reading from ui")
  59         (let* ((form (with-error->eof read (current-input-port)))
  60                (client (assq-ref (map (lambda (port)
  61                                         (cons (fileno port) port))
  62                                       clients)
  63                                  (car form))))
  64           (with-error->eof read-char (current-input-port))
  65           (if client
  66               (begin
  67                 (write (cdr form) client)
  68                 (newline client))
  69               (trc "client not found")))
  70         clients)
  71
  72       (define (accept-new-client)
  73         (cons (car (accept server)) clients))
  74
  75       (define (do-read-from-client port)
  76         (trc "reading from client")
  77         (let ((next-char (with-error->eof peek-char port)))
  78           ;;(trc 'next-char next-char)
  79           (cond ((eof-object? next-char)
  80                  (write-to-ui (list (fileno port) 'closed))
  81                  (close port)
  82                  (delq port clients))
  83                 ((char=? next-char #\()
  84                  (write-to-ui (cons (fileno port) (with-error->eof read port)))
  85                  clients)
  86                 (else
  87                  (with-error->eof read-char port)
  88                  clients))))
  89
  90       ;;(trc 'clients clients)
  91       ;;(trc 'readable-sockets readable-sockets)
  92
  93       (if (null? readable-sockets)
  94           (loop clients (car (select (cons (current-input-port)
  95                                            (cons server clients))
  96                                      '()
  97                                      '())))
  98           (loop (do-read (car readable-sockets)) (cdr readable-sockets))))))