| 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)))))) |