PageRenderTime 51ms CodeModel.GetById 2ms app.highlight 41ms RepoModel.GetById 1ms app.codeStats 0ms

/02-development/uni/mmiss/checker/src/src/share/base/socket-interface.lisp

https://bitbucket.org/jmelo_lyncode/thesis
Lisp | 985 lines | 531 code | 169 blank | 285 comment | 2 complexity | 7da237c346da51fcb7dc62336f7f4de0 MD5 | raw file
  1;;; -*- Mode: Lisp; Base: 10; Syntax: Common-lisp; Package: INKA -*-
  2;; 
  3;; ********************************************************************************************
  4;; *** This file is adapted from socket.lisp from the KEIM project written by Stephan Hess. ***
  5;; ********************************************************************************************
  6;;
  7;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;
  8;;                                                                          ;;
  9;;   Copyright (C) 1997 by AG Siekmann, Fachbereich Informatik,             ;;
 10;;   Universitaet des Saarlandes, Saarbruecken, Germany.                    ;;
 11;;   All rights reserved.                                                   ;;
 12;;   For information about this program, write to:                          ;;
 13;;     KEIM Project                                                         ;;
 14;;     AG Siekmann/FB Informatik                                            ;;
 15;;     Universitaet des Saarlandes                                          ;;
 16;;     Postfach 151150                                                      ;;
 17;;     D-66041 Saarbruecken                                                 ;;
 18;;     Germany                                                              ;;
 19;;   electronic mail: keim@cs.uni-sb.de                                     ;;
 20;;                                                                          ;;
 21;;   The author makes no representations about the suitability of this      ;;
 22;;   software for any purpose.  It is provided "AS IS" without express or   ;;
 23;;   implied warranty.  In particular, it must be understood that this      ;;
 24;;   software is an experimental version, and is not suitable for use in    ;;
 25;;   any safety-critical application, and the author denies a license for   ;;
 26;;   such use.                                                              ;;
 27;;                                                                          ;;
 28;;   You may use, copy, modify and distribute this software for any         ;;
 29;;   noncommercial and non-safety-critical purpose.  Use of this software   ;;
 30;;   in a commercial product is not included under this license.  You must  ;;
 31;;   maintain this copyright statement in all copies of this software that  ;;
 32;;   you modify or distribute.                                              ;;
 33;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;
 34
 35(in-package :inka)
 36
 37(require "service")
 38
 39;; ---------------------------------------------------------------------------
 40;; Section 0 : foreign function definitions for socket implementation
 41;; ---------------------------------------------------------------------------
 42
 43#+(and (not cmu) (not (and allegro-version>= (version>= 5 0))))
 44(progn 
 45  (ff:defforeign 'perror :arguments '(string) :pass-types '(:by-value))
 46  (ff:defforeign 'usocket)
 47  (ff:defforeign 'ubind :arguments '(integer) :pass-types '(:by-value))
 48  (ff:defforeign 'uaccept :arguments '(integer) :pass-types '(:by-value))
 49  (ff:defforeign 'uclose :arguments '(integer) :pass-types '(:by-value))
 50  (ff:defforeign 'uconnect :arguments '(string integer) :pass-types '(:by-value :by-value))
 51  (ff:defforeign 'uread :arguments '(integer integer string) :return-type :integer :pass-types '(:by-value :by-value :by-value))
 52  (ff:defforeign 'ureadwait :arguments '(integer integer string) :return-type :integer :pass-types '(:by-value :by-value :by-value))
 53  (ff:defforeign 'uwrite :arguments '(integer string) :pass-types '(:by-value :by-value))
 54  (ff:defforeign 'ugetpeername :arguments '(integer) :pass-types '(:by-value) :return-type :integer) 
 55  (ff:defforeign 'uwritefile :arguments '(integer string))
 56  )
 57
 58;; ---------------------------------------------------------------------------
 59;; Section 1 : The socket database. 
 60;; ---------------------------------------------------------------------------
 61
 62
 63(defvar socket*sockets 
 64
 65  ;;; Edited  : 02.12.1998
 66  ;;; Authors : serge
 67  ;;; Descri. : a property list of symbolic socket names and sockets.
 68    
 69  #+(and (not cmu) (not (and allegro-version>= (version>= 5 0))))  nil
 70  #+(or cmu (and allegro-version>= (version>= 5 0))) (make-hash-table) "A hashtable of symbolic socket names and sockets."
 71  )
 72
 73(defmacro socket=sockets ()
 74
 75  ;;; Edited  : 02.12.1998
 76  ;;; Authors : serge
 77  ;;; Input   : /
 78  ;;; Effect  : /
 79  ;;; Value   : the actual value of `socket*sockets
 80  
 81  `socket*sockets)
 82
 83
 84#+(and (not cmu) (not (and allegro-version>= (version>= 5 0))))
 85(defun socket-reset ()
 86
 87  ;;; Edited  : 03.12.1998
 88  ;;; Authors : serge
 89  ;;; Input   : /
 90  ;;; Effect  : resets all sockets. It closes any connected socket and removes the entries from the
 91  ;;;           socket database. 
 92  ;;; Value   : undef.
 93
 94  (setq socket*end-of-string (code-char 128))
 95  (mapcf #'(lambda (socketname socket)
 96	     (when (not (equal socket 'unconnected))
 97	       (socket-close socketname)))
 98	 (socket=sockets))
 99  (setq socket*sockets nil))
100
101#+(or cmu (and allegro-version>= (version>= 5 0)))
102(defun socket-reset ()
103  (maphash #'(lambda (socketname socket)
104	    (socket-close socketname))
105	 (socket=sockets))
106  (clrhash (socket=sockets)))
107
108
109#+(and (not cmu) (not (and allegro-version>= (version>= 5 0))))
110(defun socket=socketname.socket (socketname)
111
112  ;;; Edited  : 19. Feb 2001
113  ;;; Authors : serge       
114  ;;; Input   : 
115  ;;; Effect  : 
116  ;;; Value   : 
117
118  (getf (getf (socket=sockets) socketname) 'socket))
119
120#+(or cmu (and allegro-version>= (version>= 5 0)))
121(defun socket=socketname.socket (socketname)
122
123  ;;; Edited  : 19. Feb 2001
124  ;;; Authors : serge       
125  ;;; Input   : 
126  ;;; Effect  : 
127  ;;; Value   : 
128
129  (getf (gethash socketname (socket=sockets)) 'socket))
130
131#+(and (not cmu) (not (and allegro-version>= (version>= 5 0))))
132(defun socket=socketname.buffer-string (socketname)
133
134  ;;; Edited  : 19. Feb 2001
135  ;;; Authors : serge       
136  ;;; Input   : 
137  ;;; Effect  : 
138  ;;; Value   : 
139
140  (getf (getf (socket=sockets) socketname) 'buffer-string))
141
142
143#+(or cmu (and allegro-version>= (version>= 5 0)))
144(defun socket=socketname.buffer-string (socketname)
145
146  ;;; Edited  : 19. Feb 2001
147  ;;; Authors : serge       
148  ;;; Input   : 
149  ;;; Effect  : 
150  ;;; Value   : 
151
152  (getf (gethash socketname (socket=sockets)) 'buffer-string))
153
154
155
156#+(and (not cmu) (and allegro-version>= (version>= 5 0)))
157(defun socket-find.socket (socketname)
158  (socket=socketname.socket socketname))
159
160
161;; ---------------------------------------------------------------------------
162;; Section 2 : Defining/Undefining sockets.
163;; ---------------------------------------------------------------------------
164
165
166#+(and (not cmu) (not (and allegro-version>= (version>= 5 0))))
167(defun socket-define (socketname)
168
169  ;;; Edited  : 02.12.1998
170  ;;; Authors : serge
171  ;;; Input   : an sexpr which is the symbolic name of a socket. 
172  ;;; Effect  : creates an entry for this socket.
173  ;;; Value   : undef. 
174  
175  (cond ((and socketname (null (getf socket*sockets socketname)))
176	 (setf (getf (getf socket*sockets socketname) 'port) nil)
177	 (setf (getf (getf socket*sockets socketname) 'socket) 'unconnected)
178	 (setf (getf (getf socket*sockets socketname) 'buffer-string) "")
179	 )
180	((null socketname) 
181	 (format t "Invalid socket name ~A!" socketname))
182	(T (print "Redefinition of existing socket-names is not allowed!")
183	   nil)))
184	 
185
186#+(or cmu (and allegro-version>= (version>= 5 0)))
187(defun socket-define (socketname)
188
189  ;;; Edited  : 20-SEP-2000
190  ;;; Authors : pollet       
191  ;;; Input   : An sexpr which is the symbolic name of a socket.
192  ;;; Effect  : Creates an entry for this socket.
193  ;;; Value   : T for success, NIL for failure.
194
195  (cond ((and socketname (null (gethash socketname socket*sockets)))
196	 (setf (getf (gethash socketname socket*sockets) 'socket) 'unconnected)
197	 (setf (getf (gethash socketname socket*sockets) 'buffer-string) "")
198	 T)
199	((null socketname)
200	 (format t "Invalid socket name ~A!" socketname)
201	 nil)
202	(T 
203	 (print "Redefinition of existing socket-names is not allowed!")
204	 nil)))
205
206#+(and (not cmu) (not (and allegro-version>= (version>= 5 0))))
207(defun socket-delete (socketname)
208  
209  ;;; Edited  : 17.03.1997 01.12.1998
210  ;;; Authors : hess       serge
211  ;;; Input   : an sexpr defining a socket, i.e. a socketname
212  ;;; Effect  : deletes the socketname
213  ;;; Value   : /
214
215  (let ((socket (getf (socket=sockets) socketname)))
216    (cond ((and socket (equal (getf socket 'socket) 'unconnected))
217	   (remf socket*sockets socketname))
218	  ((null socket) (format t "Unknown socket ~A given to socket-undefine!" socketname) "")
219	  (t (format t "Socket ~A is still connected in socket-delete!" socketname) ""))))
220
221
222#+(or cmu (and allegro-version>= (version>= 5 0)))
223(defun socket-delete (socketname)
224
225  ;;; Edited  : 20-SEP-2000 14. Feb 2001
226  ;;; Authors : Pollet      serge       
227  ;;; Input   : An sexpr defining a socket, i.e. a socketname.
228  ;;; Effect  : Deletes the socketname.
229  ;;; Value   : T for success, NIL for failure.
230
231  (let ((socket (socket=socketname.socket socketname)))
232    (cond ((and socket (equal socket 'unconnected))
233	   (remhash socketname socket*sockets)
234	   T)
235	  ((null  socket)
236	   (format t "Unknown socket ~A given to socket-undefine!"
237		   socketname)
238	   nil
239	   )
240	  (t (format t "Socket ~A is still connected in socket-delete!" socketname)
241	     nil
242	     ))))
243
244
245#+(and (not cmu) (not (and allegro-version>= (version>= 5 0))))
246(defun socket-active? (socketname)
247
248  ;;; Edited  : 11. Feb 1999
249  ;;; Authors : serge       
250  ;;; Input   : a socketname
251  ;;; Effect  : checks whether a socket of this name exists and, if so, if it is connected.
252  ;;; Value   : T, if the check succeeds; NIL otherwise.
253  
254  (let ((socket (getf (socket=sockets) socketname))
255	(astring (make-string 1))
256	val)
257    (if (getf socket 'port) t
258      (cond ((and socket (numberp (getf socket 'socket)) T)
259	     (setq val (uread (getf socket 'socket) 1 astring))
260	     (cond ((eq val -2) ;; Socket is there, but nothing on the socket.
261		    T)
262		   ((eq val 1) ;; Socket is there and read one character.
263		    ;; Saving the character in the buffer-string of the socket.
264		    (setf (getf (getf (socket=sockets) socketname) 'buffer-string) 
265			  (concatenate 'string 
266				       (getf (getf (socket=sockets) socketname) 'buffer-string) (copy-seq (string (elt  astring 0)))))
267		    T)))))))
268
269
270#+(or cmu (and allegro-version>= (version>= 5 0)))
271(defun socket-active? (socketname)
272
273  ;;; Edited  : 20-SEP-2000 14. Feb 2001
274  ;;; Authors : Pollet      serge       
275  ;;; Input   : A socketname.
276  ;;; Effect  : Checks whether a socket of this name exists and, if so, if it is connected.
277  ;;; Value   : T, if the check succeeds; NIL otherwise.
278
279  (let ((socket (socket=socketname.socket socketname)))
280    (and socket
281	 (or (and (streamp socket) (open-stream-p socket)
282		  (not (and (listen socket)
283			    (eq (peek-char nil socket nil 'eof) 'eof))))  ;active sockets
284	     (not (equal socket 'unconnected))))))                       ;passive sockets
285
286#+(or cmu (and allegro-version>= (version>= 5 0)))
287(defun socket-active? (socketname)
288
289  ;;; Edited  : 20-SEP-2000 14. Feb 2001
290  ;;; Authors : Pollet      serge       
291  ;;; Input   : A socketname.
292  ;;; Effect  : Checks whether a socket of this name exists and, if so, if it is connected.
293  ;;; Value   : T, if the check succeeds; NIL otherwise.
294
295  (let ((socket (socket=socketname.socket socketname)))
296    (and socket
297	 (streamp socket)
298	 (open-stream-p socket)
299	 )))
300
301
302#+(and (not cmu) (not (and allegro-version>= (version>= 5 0))))
303(defun socket-receives? (socketname)
304
305  ;;; Edited  : 10. Mar 1999
306  ;;; Authors : serge       
307  ;;; Input   : a socketname 
308  ;;; Effect  : checks whether there is something coming over the socket.
309  ;;; Value   : T, if there is something; NIL otherwise.
310
311  (let ((socketentry (getf (socket=sockets) socketname))
312	(astring (make-string 1))
313	val)
314    (cond ((and socketentry (numberp (getf socketentry 'socket)) T)
315	   (setq val (uread (getf socketentry 'socket) 1 astring))
316	   (cond ((eq val -2) ;; Socket is there, but nothing on the socket.
317		  nil)
318		 ((eq val 1) ;; Socket is there and read one character.
319		  ;;; Saving the character in the buffer-string of the socket.
320		  (setf (getf (getf (socket=sockets) socketname) 'buffer-string) 
321		    (concatenate 'string 
322		      (getf (getf (socket=sockets) socketname) 'buffer-string) (copy-seq (string (elt  astring 0)))))
323		  T))))))
324  
325#+(or cmu (and allegro-version>= (version>= 5 0)))
326(defun socket-receives? (socketname)
327
328  ;;; Edited  : 20-SEP-2000 14. Feb 2001
329  ;;; Authors : Pollet serge       
330  ;;; Input   : A socketname.
331  ;;; Effect  : Checks whether there is something coming over the socket.
332  ;;; Value   : T, if there is something; NIL otherwise.
333
334  (let ((socket (socket=socketname.socket socketname)))
335    (and socket (socket-active? socketname) 
336	 #+(and allegro-version>= (version>= 5 0)) (stream::stream-listen socket)
337	 #+CMU (common-lisp:listen socket)
338	 )))
339
340#+(and (not cmu) (not (and allegro-version>= (version>= 5 0))))
341(defun socket-fd (socketname)
342
343  ;;; Edited  : 12. Mar 1999
344  ;;; Authors : serge       
345  ;;; Input   : a socketname
346  ;;; Effect  : /
347  ;;; Value   :the file descriptor of this socket
348
349  (getf (getf (socket=sockets) socketname) 'socket)
350  )
351
352#+(or cmu (and allegro-version>= (version>= 5 0)))
353(defun socket-fd (socketname)
354
355  ;;; Edited  : 20-SEP-2000 14. Feb 2001
356  ;;; Authors : Pollet      serge       
357  ;;; Input   : A socketname.
358  ;;; Effect  : -
359  ;;; Value   : The file descriptor of this socket.
360
361  (let ((socket (socket=socketname.socket socketname)))
362    (when (socket-active? socketname) 
363      #+(and allegro-version>= (version>= 5 0)) (socket::socket-os-fd socket)
364      #+cmu (SYSTEM:FD-STREAM-FD socket)
365      )))
366
367;; ---------------------------------------------------------------------------
368;; Section 3 : Connecting/Closing sockets.
369;; ---------------------------------------------------------------------------
370
371
372#+(and (not cmu) (not (and allegro-version>= (version>= 5 0))))
373(defun socket-connect (host port socketname)
374
375  ;;; Edited  : 17.03.1997 01.12.1998
376  ;;; Authors : hess       serge
377  ;;; Input   : A host and a portnumber to connect to.
378  ;;; Effect  : Connects to the specified socket.
379  ;;; Value   : /
380
381  (let (socket)
382    (cond ((and (setq socket (getf (socket=sockets) socketname)) 
383		(eq (getf socket 'socket) 'unconnected))
384	   (setf (getf (getf socket*sockets socketname) 'socket) (uconnect host port)))
385	  ((null socket)
386	   (format t "Socket name ~A not defined" socketname))
387	  (t (format t "Socket ~A already connected." socketname)))))
388
389
390#+(or cmu (and allegro-version>= (version>= 5 0)))
391(defun socket-connect (host port socketname)
392
393  ;;; Edited  : 20-SEP-2000 14. Feb 2001
394  ;;; Authors : Pollet      serge       
395  ;;; Input   : A host and a portnumber to connect to.
396  ;;; Effect  : Connects to the specified socket.
397  ;;; Value   : T for success, NIL for failure.
398
399  (let (socket)
400    (cond ((and (setq socket (socket=socketname.socket socketname))
401		(equal socket  'unconnected))
402	   (setf (gethash socketname socket*sockets)
403		 (list 'socket 
404		       #+(and allegro-version>= (version>= 5 0)) 
405		       (socket::make-socket :remote-host host
406					    :remote-port port
407					    :type :stream
408					    :address-family :internet
409					    :connect :active)
410		       #+CMU 
411		       (system:make-fd-stream (connect-to-inet-socket host port)
412					      :input t :output t)
413		       'buffer-string ""))
414	   T)
415	  ((null socket)
416	   (format t "Socket name ~A not defined" socketname)
417	   nil)
418	  (t (format t "Socket ~A already connected." socketname)
419	     nil))))
420
421#+(and (not cmu) (not (and allegro-version>= (version>= 5 0))))
422(defun socket-close (socketname)
423  
424  ;;; Edited  : 17.03.1997 01.12.1998
425  ;;; Authors : hess       serge
426  ;;; Input   : /
427  ;;; Effect  : Closes the connection to the socket.
428  ;;; Value   : /
429
430  (let ((socket (getf (socket=sockets) socketname)))
431    (cond ((and socket (not (equal (getf socket 'socket) 'unconnected)))
432	   (when (> (uclose (getf socket 'socket)) -1)
433	     (setf (getf socket 'port) nil)
434	     (setf (getf socket 'socket) 'unconnected))
435	   (setf (getf socket 'buffer-string) "")
436	   )
437	  ((null  socket) (format t "Unknown socket ~A given to socket-close!" socketname) "")
438	  (t (format t "Socket ~A is not connected in socket-close!" socketname) ""))))
439
440
441#+(or cmu (and allegro-version>= (version>= 5 0)))
442(defun socket-close (socketname)
443
444  ;;; Edited  : 20-SEP-2000 14. Feb 2001
445  ;;; Authors : Pollet      serge       
446  ;;; Input   : A socket name.
447  ;;; Effect  : Closes the connection to the socket. If error-p is not NIL an error is
448  ;;;           signaled on failure.
449  ;;; Value   : T for success, NIL for failure.
450
451  (let ((socket (socket=socketname.socket socketname)))
452    (cond ((and socket (not (equal socket 'unconnected)))
453	   #+(and allegro-version>= (version>= 5 0)) (socket::close socket)
454	   #+CMU                                     (close-socket (SYSTEM:FD-STREAM-FD socket))
455	   (setf (getf (gethash socketname (socket=sockets)) 'socket) 'unconnected)
456	   T)
457	  ((null  socket)
458	   (format t "Unknown socket ~A given to socket-close!" socketname)
459	   nil
460	   )
461	  (t (format t "Socket ~A is not connected in socket-close!" socketname)
462	     nil
463	     ))))
464
465;; ---------------------------------------------------------------------------
466;; Section 4 : Read from/Write to sockets.
467;; ---------------------------------------------------------------------------
468
469
470(defvar socket*end-of-string 
471
472  ;;; Edited  : 09.12.1998
473  ;;; Authors : serge
474  ;;; Descri. : the character indicating the end of a string to be read from a socket. 
475
476  (code-char 128))
477
478
479(proclaim '(type character socket*end-of-string))
480
481(defmacro socket=end-of-string ()
482
483  ;;; Edited  : 09.12.1998
484  ;;; Authors : serge
485  ;;; Input   : /
486  ;;; Effect  : /
487  ;;; Value   : the actual value of `socket*end-of-string
488
489  `socket*end-of-string)
490
491
492#+(and (not cmu) (not (and allegro-version>= (version>= 5 0))))
493(defun socket=readloop (socket &optional wait? (eos (socket=end-of-string)))
494
495  ;;; Edited  : 17.03.1997 01.12.1998 09.12.1998 12. Jan 1999 19. Feb 1999
496  ;;; Authors : hess       serge      serge      serge        serge       
497  ;;; Input   : a socket description, which is a property list ('SOCKET socket 'BUFFER-STRING string)
498  ;;; Effect  : /
499  ;;; Value   : A string read from the socket, if there is some terminating with (socket=end-of-string). 
500  ;;;           NIL if there is nothing on the socket. If there is something on the socket, but the end-of-string
501  ;;;           character (socket=end-of-string) has not been read, waits for this character. 
502  
503  (let ((val 1)
504	(astring (make-string 1 :initial-element (code-char 32)))
505	(local-stream (make-string-output-stream))
506	(overall-string (getf socket 'buffer-string))
507	(the-socket (getf socket 'socket))
508	(result nil)
509	tmp)
510    ;; Writing the actual content of the socket-buffer into the local-stream
511    (write-string (socket=socketname.buffer-string socketname) local-stream)
512    (do ()
513	;;; Read from socket one character, until we got the end-of-string character or an error. 
514	((or (eq eos (elt astring 0)) (< val 1)))
515      (when (eq 1 (setq val (if wait? (ureadwait the-socket 1 astring) 
516			      (uread the-socket 1 astring))))
517	;;; Store the recently read character in the overall string.
518	(unless (eq eos (elt astring 0))
519	  (when (and tmp (eq tmp #\\)
520		     (not (member (elt astring 0) (list #\\ #\"))))
521	    (write-char #\\ local-stream))
522	  (write-char (elt astring 0) local-stream)
523	  (setq tmp (elt  astring 0))))
524      ;; (setq overall-string (concatenate 'string overall-string (copy-seq (string (elt astring 0))))))
525      )
526    (cond ((< val 1) ;;; if we got an error on the socket, save the string read so far in the socket buffer and return NIL.
527	   (setq result nil)
528	   (setf (getf socket 'buffer-string) (get-output-stream-string local-stream))
529	   (cond ;; ((eq val -2) ;; (format t "No more symbols on the socket.~%"))
530		 ((eq val -1) (format t "General read error on the socket.~%"))
531		 ((eq val 0) (format t "Got an EOF on the socket. The other side might have closed/lost the socket.~%")))
532	   )
533	  (T ;;; otherwise return the actual string and delete the socket buffer.
534	   (setf (getf socket 'buffer-string) "")
535	   (setq result (get-output-stream-string local-stream))))
536    result))
537
538#+(or cmu (and allegro-version>= (version>= 5 0)))
539(defun socket=readloop (socketname &optional wait? (eos (socket=end-of-string)))
540
541  ;;; Edited  : 20-SEP-2000 14. Feb 2001
542  ;;; Authors : Pollet      serge       
543  ;;; Input   : A socket.
544  ;;; Effect  : -
545  ;;; Value   : A string read from the socket, if there is some terminating with (socket=end-of-string).
546  ;;;           NIL if there is nothing on the socket. If there is something on the socket, but the end-of-string
547  ;;;           character (socket=end-of-string) has not been read, waits for this character.
548
549  (let 	((astring nil)
550	 (socket (socket=socketname.socket socketname))
551	 (local-stream (make-string-output-stream))
552	 (result nil)
553	 (tmp nil))
554    ;; Writing the actual content of the socket-buffer into the local-stream
555    (write-string (socket=socketname.buffer-string socketname) local-stream)
556    (do ()
557	;;; Read from socket one character, until we got the end-of-string character or an error. 
558	((or (eq eos astring)
559	     (eq astring :eof)
560	     )
561	 )
562      (when (socket-receives? socketname) 
563	(setf astring 
564	      #+ALLEGRO (if wait? (stream-read-char socket) (read-char-no-hang socket))
565	      #+CMU18   (if wait? (common-lisp:read-char socket) (common-lisp:read-char-no-hang socket))
566	      )
567	;; (format t "Read on socket ~A the character: ~S~%" socketname astring)
568	;; Store the recently read character in the overall string.
569	(unless (or (eq eos astring) (eq astring :eof))
570	  (when (and tmp (eq tmp #\\)
571		     (not (member astring (list #\\ #\"))))
572	    (write-char #\\ local-stream))
573	  (write-char astring local-stream)
574	  (setq tmp astring)))
575      )
576    (cond ((and astring (eq astring eos))
577	   (setq result (get-output-stream-string local-stream))
578	   (setf (getf (gethash socketname (socket=sockets)) 'buffer-string) ""))
579	  ((socket-active? socketname)
580	   (setf (getf (gethash socketname (socket=sockets)) 'buffer-string) 
581		 (get-output-stream-string local-stream)))
582	  (t (format t "General read error on the socket. The other side might have loast/closed the connection.~%")))
583    result))
584
585
586#+(and (not cmu) (not (and allegro-version>= (version>= 5 0))))
587(defun socket-read (socketname &optional (wait? nil) (eos (socket=end-of-string)))
588
589  ;;; Edited  : 24.03.1997 01.12.1998  19. Feb 1999
590  ;;; Authors : hess       serge       serge       
591  ;;; Input   : /
592  ;;; Effect  : Write handshake signal to socket.
593  ;;; Value   : The string read from the socket.
594  
595  (let* ((socket (getf (socket=sockets) socketname)))
596    (cond ((and socket (not (equal (getf socket 'socket) 'unconnected)))
597	   (socket=readloop socket wait? eos))
598	  ((null socket) (format t "Unknown socket ~A given to read from!" socketname) "")
599	  (t (format t "Socket ~A is not connected in read-socket!" socketname) ""))))
600
601#+(or cmu (and allegro-version>= (version>= 5 0)))
602(defun socket-read (&optional (socketname :inout) (wait? nil) (eos (socket=end-of-string)))
603
604  ;;; Edited  : 20-SEP-2000 14. Feb 2001
605  ;;; Authors : Pollet      serge       
606  ;;; Input   : Socketname, wait-switch, signal-error-switch.
607  ;;; Effect  : Write handshake signal to socket. If error-p is not NIL an error is
608  ;;;           signaled on failure.
609  ;;; Value   : The string read from the socket on success, the empty string on failure.
610
611  (let* ((socket (socket=socketname.socket socketname)))
612    (cond ((and socket (not (equal socket 'unconnected))) 
613	   (socket=readloop socketname wait? eos))
614	  ((null socket)
615	   (format t "Unknown socket ~A given to read from!" socketname)
616	   "")
617	  (t
618	   (format t "Socket ~A is not connected in read-socket!" socketname)
619	   ""))))
620
621#+(and (not cmu) (not (and allegro-version>= (version>= 5 0))))
622(defun socket-write (string socketname &optional (eos (socket=end-of-string)))
623  
624  ;;; Edited  : 24.03.1997 01.12.1998
625  ;;; Authors : hess       serge
626  ;;; Input   : A string and the name of a socket.
627  ;;; Effect  : Wait for ready signal, then write string to socket.
628  ;;; Value   : undef. 
629
630  (let ((socket (getf (socket=sockets) socketname)))
631    (cond ((and socket (not (equal (getf socket 'socket) 'unconnected)))
632	   (uwrite (getf socket 'socket) (concatenate 'string string (string eos))))
633	  ((null socket) (format t "Unknown socket ~A given to write to!" socketname) nil)
634	  (t (format t "Socket ~A is not connected in write-socket!" socketname) nil))))
635
636
637#+(or cmu (and allegro-version>= (version>= 5 0)))
638(defun socket-write (string &optional (socketname :inout)
639			    (eos (string socket*end-of-string))
640			    )
641
642  ;;; Edited  : 20-SEP-2000 14. Feb 2001
643  ;;; Authors : Pollet      serge       
644  ;;; Input   : A string and the name of a socket.
645  ;;; Effect  : Wait for ready signal, then write string to socket..
646  ;;; Value   : T for success, NIL for failure.
647
648  (let ((socket (socket=socketname.socket socketname)))
649    (cond ((and socket (not (equal socket 'unconnected)))
650	   (write-string (concatenate 'string string (string eos)) socket)
651	   (force-output socket)
652	   T)
653	  ((null socket)
654	   (format t "Unknown socket ~A given to write to!" socketname)
655	   nil
656	   )
657	  (t
658	   (format t "Socket ~A is not connected in write-socket!" socketname)
659	   nil
660	   ))))
661
662
663;; ---------------------------------------------------------------------------
664;; Section 5 : Stuff for TCP-Server and HTTP
665;; ---------------------------------------------------------------------------
666
667#+(and (not cmu) (not (and allegro-version>= (version>= 5 0))))
668(defun socket-bind (port socketname)
669
670  ;;; Edited  : 04. Aug 2000  06. Sep 2000
671  ;;; Authors : Pollet        serge       
672  ;;; Input   : A port and a the socketname of a defined socket.
673  ;;; Effect  : Establish a server at port PORT. If error-p in not NIL an error is
674  ;;;           signaled on failure.
675  ;;; Value   : T for success, NIL for failure.
676  
677  (let ((socket (getf (socket=sockets) socketname)))
678    (if socket
679	(if (eq (getf socket 'socket) 'unconnected)
680	    (let ((fd (ubind port)))
681	      (if (and (numberp fd) (plusp fd))
682		  (progn
683		    (setf (getf socket 'socket) fd)
684		    (setf (getf socket 'port) port)
685		    t)
686		(progn (format t "Problems to bind port ~A to socket ~A." port socketname)
687		       nil)))
688	  (progn (format t "Socket ~A already connected." socketname)
689		 nil))
690      (progn (format t "Socket name ~A not defined" socketname)
691	     nil))))
692
693#+(or cmu (and allegro-version>= (version>= 5 0)))
694(defun socket-bind (port socketname)
695
696  ;;; Edited  : 04-AUG-2000 14. Feb 2001
697  ;;; Authors : Pollet      serge       
698  ;;; Input   : A port and a the socketname of a defined socket.
699  ;;; Effect  : Establish a server at port PORT. If error-p in not NIL an error is
700  ;;;           signaled on failure.
701  ;;; Value   : T for success, NIL for failure.
702
703  (let ((socket (socket=socketname.socket socketname))
704	(newsocket nil))
705    (if socket
706	(if (eq socket 'unconnected)
707	    #+(and allegro-version>= (version>= 5 0))
708	    (handler-case 
709	     (progn (setf (getf (gethash socketname (socket=sockets)) 'socket)  
710			  (socket::make-socket :connect :passive :local-port port))
711		    t)
712	     (excl::socket-error (x) 
713				 (format t "Error ~%~A~% while binding socket ~A on port ~D!~%" x socketname port)
714				 nil))
715	    #+CMU 
716	    (handler-case 
717	     (progn (setf (getf (gethash socketname (socket=sockets)) 'socket)
718			  (system:make-fd-stream (create-inet-listener port)
719						 :input t :output t))
720		    T)
721	     (error (x) 
722		    (format t "Error ~%~A~% while binding socket ~A on port ~D!~%" x socketname port)
723		    nil))
724	  (progn (format t "Socket ~A already connected." socketname)
725		 nil))
726      (progn
727	(format t "Socket name ~A not defined" socketname)
728	nil))))
729
730#+(and (not cmu) (not (and allegro-version>= (version>= 5 0))))
731(defun socket-accept (serversocket connectsocket)
732
733  ;;; Edited  : 04. Aug 2000  06. Sep 2000
734  ;;; Authors : Pollet        serge       
735  ;;; Input   : Two socketnames
736  ;;; Effect  : Waits for a connection on SERVERSOCKET. If this
737  ;;;           happens, CONNECTSOCKET will be connected to client.
738  ;;; Value   : T for success, NIL for failure.
739
740  (let ((ssock (getf (socket=sockets) serversocket))
741	(csock (getf (socket=sockets) connectsocket)))
742    (if (and csock ssock)
743	(if (eq (getf csock 'socket) 'unconnected)
744	    (let ((fd (uaccept (getf ssock 'socket))))
745	      (if (and (numberp fd) (plusp fd))
746		  (progn (setf (getf csock 'socket) fd)
747			 t)
748		(progn (format t "Problems to accept ~A." serversocket)
749		       nil)))
750	  (progn (format t "Socket ~A already connected." connectsocket)
751		 nil))
752      (progn (format t "Socket name ~A or ~A not defined" serversocket connectsocket)
753	     nil))))
754
755
756#+(or cmu (and allegro-version>= (version>= 5 0)))
757(defun socket-accept (serversocket connectsocket)
758
759  ;;; Edited  : 04-AUG-2000 14. Feb 2001
760  ;;; Authors : Pollet      serge       
761  ;;; Input   : Two socketnames.
762  ;;; Effect  : Waits for a connection on SERVERSOCKET. If this happens, CONNECTSOCKET will be connected to client.
763  ;;;           If error-p is not NIL an error is signalled on failure.
764  ;;; Value   : T for success, NIL for failure.
765
766  (let ((ssock (socket=socketname.socket serversocket))
767	(csock (socket=socketname.socket connectsocket)))
768    (cond ((not (and csock ssock))
769	   (format t "Socket name ~A or ~A not defined" serversocket connectsocket)
770	   nil)
771	  ((not (eq csock 'unconnected))
772	   (format t "Socket ~A already connected." connectsocket)
773	   nil)
774	  ((eq ssock 'unconnected)
775	   (format t "Socket ~A not connected." connectsocket)
776	   nil)
777	  ((streamp csock)
778	   (format t "Socket ~A is not a passive socket." connectsocket)
779	   nil)
780	  (T
781	   (progn
782	     (setf (getf (gethash connectsocket (socket=sockets)) 'socket)
783		   #+(and allegro-version>= (version>= 5 0)) (socket::accept-connection ssock)
784		   #+CMU (system:make-fd-stream (accept-tcp-connection (system:fd-stream-fd ssock))
785						:input t :output t)
786		   )
787	     T)))))
788
789#+(and (not cmu) (not (and allegro-version>= (version>= 5 0))))
790(defun socket=readuntil (socket what &optional wait?)
791
792  ;;; Edited  : 06. Aug 2000 06. Sep 2000
793  ;;; Authors : pollet       serge       
794  ;;; Input   : a socket description, which is a property list ('SOCKET socket 'BUFFER-STRING string)
795  ;;;           and a NUMBER or CHAR.
796  ;;; Effect  : Reads NUMBER chars from the socket or untill CHAR or (socket=end-of-string)
797  ;;; Value   : Returns a string containing the chars read.
798  
799  (let* ((val 1)
800	 (astring (make-string 1 :initial-element (code-char 32)))
801	 (local-stream (make-string-output-stream))
802	 (overall-string (getf socket 'buffer-string))
803	 (the-socket (getf socket 'socket))
804	 (result nil)
805	 (counter 0)
806	 (test (etypecase what
807		 (number #'(lambda (x)(declare (ignore x))(= counter what)))
808		 (character #'(lambda (x)(eq what (elt x 0))))
809		 (null #'(lambda (x)(declare (ignore x)) nil)))))
810		
811    (do ()
812	;;; Read from socket one character, until we got the end-of-string character or an error. 
813	((or (funcall test astring)
814	     (eq (socket=end-of-string) (elt astring 0))
815	     (= val 0)
816	     ))
817      (when (eq 1 (setq val (if wait? (ureadwait the-socket 1 astring) 
818			      (uread the-socket 1 astring))))
819	;; Store the recently read character in the overall string.
820	;; (if not eq to socket=end-of-string
821	(unless (or (eq (socket=end-of-string) (elt astring 0)))
822	  (setq counter (1+ counter))
823	  (write-char (elt  astring 0) local-stream)))
824      ;; (setq overall-string (concatenate 'string overall-string (copy-seq (string (elt astring 0))))))
825      )
826    (cond ((and (< val 1)(not (= val -2))) ;;; if we got an error on the socket, save the string read so far in the socket buffer and return NIL.
827	   (setq result nil)
828	   (setf (getf socket 'buffer-string) 
829	     (concatenate 'string overall-string (get-output-stream-string local-stream)))
830	   (cond ;; ((eq val -2) ;; (format t "No more symbols on the socket.~%"))
831	         ((eq val -1) (format t "General read error on the socket.~%"))
832		 ((eq val 0) (format t "Got an EOF on the socket. The other side might have closed/lost the socket.~%")))
833	   )
834	  (T ;;; otherwise return the actual string and delete the socket buffer.
835	   (setf (getf socket 'buffer-string) "")
836	   (setq result 
837	     (concatenate 'string overall-string (get-output-stream-string local-stream)))))
838    result))
839
840
841#+(and (not cmu) (not (and allegro-version>= (version>= 5 0))))
842(defun socket-read.line (socketname &optional (wait? nil))
843
844  ;;; Edited  : 06. Aug 2000 06. Sep 2000
845  ;;; Authors : pollet       serge       
846  ;;; Input   : Socketname.
847  ;;; Effect  : Write handshake signal to socket. If error-p is not NIL an error is signaled on failure.
848  ;;; Value   : The string containing the line read from the socket.
849
850  (let* ((socket (getf (socket=sockets) socketname)))
851    (cond ((and socket (not (equal (getf socket 'socket) 'unconnected))) 
852	   (socket=readuntil socket #\newline wait?))
853	  ((null socket)
854	   (format t "Unknown socket ~A given to read from!" socketname)
855	   "")
856	  (t (format t "Socket ~A is not connected in read-socket!" socketname)
857	     ""))))
858
859#+(or cmu (and allegro-version>= (version>= 5 0)))
860(defun socket-read.line (socketname &optional (wait? nil))
861
862  ;;; Edited  : 06-AUG-2000 14. Feb 2001
863  ;;; Authors : Pollet      serge       
864  ;;; Input   : Socketname.
865  ;;; Effect  : Write handshake signal to socket. If error-p is not NIL an error is signaled on failure.
866  ;;; Value   : The string containing the line read from the socket.
867
868  (let* ((socket (socket=socketname.socket socketname)))
869    (cond ((and socket (not (equal socket 'unconnected)))
870	   (read-line socket nil nil))
871	  ((null socket)
872	   (format t "Unknown socket ~A given to read from!" socketname)
873	   "")
874	  (t (format t "Socket ~A is not connected in read-socket!" socketname)
875	     ""))))
876
877
878#+(and (not cmu) (not (and allegro-version>= (version>= 5 0))))
879(defun socket-read.content (size socketname &optional (wait? nil) (error-p nil))
880
881  ;;; Edited  : 06. Aug 2000 06. Sep 2000
882  ;;; Authors : pollet       serge       
883  ;;; Input   : Socketname and a number.
884  ;;; Effect  : Write handshake signal to socket. If error-p is not NIL an error is signaled on failure.
885  ;;; Value   : The string containing SIZE chars read from the socket.
886  
887  (let* ((socket (getf (socket=sockets) socketname)))
888    (cond ((and socket (not (equal (getf socket 'socket) 'unconnected))) 
889	   (socket=readuntil socket size wait?))
890	  ((null socket)
891	   (format t "Unknown socket ~A given to read from!" socketname)
892	   "")
893	  (t (format t "Socket ~A is not connected in read-socket!" socketname)
894	     ""))))
895
896
897#+(or cmu (and allegro-version>= (version>= 5 0)))
898(defun socket-read.content (size socketname &optional (wait? nil))
899
900  ;;; Edited  : 06-AUG-2000 14. Feb 2001
901  ;;; Authors : Pollet      serge       
902  ;;; Input   : Socketname and a number.
903  ;;; Effect  : Write handshake signal to socket. If error-p is not NIL an error is signaled on failure.
904  ;;; Value   : The string containing SIZE chars read from the socket.
905
906  ;; (warn "Socket-read.content with size ~A" size)
907  (let* ((socket (socket=socketname.socket socketname)))
908    (cond ((and socket (not (equal socket 'unconnected)))
909	   (let ((input (make-string size)))
910	     (read-sequence input socket)
911	     input))	  
912	  ((null socket)
913	   (format t "Unknown socket ~A given to read from!" socketname)
914	   "")
915	  (t (format t "Socket ~A is not connected in read-socket!" socketname)
916	     ""))))
917
918
919#+(and (not cmu) (not (and allegro-version>= (version>= 5 0))))
920(defun socket-write.file (header pathname &optional (socketname :inout)
921				 (eos (string socket*end-of-string))
922				 (error-p nil))
923  
924  ;;; Edited  : 24.03.1997 01.12.1998
925  ;;; Authors : hess       serge
926  ;;; Input   : A string and the name of a socket.
927  ;;; Effect  : Wait for ready signal, then write string to socket. If error-p is not NIL
928  ;;;           an error is signaled on failure.
929  ;;; Value   : T for success, NIL for failure. 
930
931  (let ((socket (getf (socket=sockets) socketname)))
932    (cond ((and socket (not (equal (getf socket 'socket) 'unconnected)))
933	   (uwrite (getf socket 'socket) header)
934	   (uwritefile (getf socket 'socket) pathname)
935	   T)
936	  ((null socket)
937	   (when error-p
938	     (error "Unknown socket ~A given to write to!" socketname))
939	   (format t "Unknown socket ~A given to write to!" socketname)
940	   nil
941	   )
942	  (t
943	   (when error-p
944	     (error "Unknown socket ~A given to write to!" socketname))
945	   (format t "Socket ~A is not connected in write-socket!" socketname)
946	   nil
947	   ))))
948
949
950#+(and (not cmu) (not (and allegro-version>= (version>= 5 0))))
951(defun socket-get.peername (socketname)
952
953  ;;; Edited  : 29. Aug 2000 06. Sep 2000
954  ;;; Authors : pollet       serge       
955  ;;; Input   : A Socketname
956  ;;; Effect  : Calls the foreign functions 'ugetpeername'.
957  ;;; Value   : A string with the IP number of the connected host.
958  
959  (let ((socket (getf (socket=sockets) socketname))
960	val)
961    (when (and socket (numberp (getf socket 'socket))
962	       (setq val (ugetpeername (getf socket 'socket))))
963      (unless (= val -1)
964	#+(or allegro-v5.0 allegro-v5.0.1)(excl:native-to-string val)
965	#+(or allegro-v4.3 allegro-v4.3.1)(ff:char*-to-string val)
966	))))
967
968#+(or cmu (and allegro-version>= (version>= 5 0)))
969(defun socket-get.peername (socketname)
970
971  ;;; Edited  : 29-AUG-2000 14. Feb 2001
972  ;;; Authors : Pollet      serge       
973  ;;; Input   : A Socketname
974  ;;; Effect  : -
975  ;;; Value   : A string with the IP number of the connected host.
976
977  (let ((socket (socket=socketname.socket socketname)))
978    (when socket
979      #+(and allegro-version>= (version>= 5 0)) (socket::ipaddr-to-dotted (socket::remote-host socket))
980      #+CMU  (multiple-value-bind (ipaddr port) (get-peer-host-and-port (system:fd-stream-fd socket))
981	       ipaddr)
982      )))
983
984
985(provide "socket-interface")