Commit | Line | Data |
---|---|---|
32ac6ed1 NJ |
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)))))) |