[usocket-cvs] r194 - trivial-usocket/trunk

[ehuelsmann at common-lisp.net]

Author: ehuelsmann
Date: Sun Jan 21 08:17:08 2007
New Revision: 194

Modified:
   trivial-usocket/trunk/trivial-usocket.asd   (props changed)
   trivial-usocket/trunk/trivial-usocket.lisp   (contents, props changed)
Log:
Complete trivial-sockets compat (by implementing server sockets).

Modified: trivial-usocket/trunk/trivial-usocket.lisp
==============================================================================
--- trivial-usocket/trunk/trivial-usocket.lisp	(original)
+++ trivial-usocket/trunk/trivial-usocket.lisp	Sun Jan 21 08:17:08 2007
@@ -10,7 +10,10 @@
         #:usocket)
   (:export #:open-stream
            #:usocket
-           #:unsupported))
+           #:unsupported
+           #:open-server
+           #:with-server
+           #:accept-connection))
 
 (in-package :trivial-usocket)
 
@@ -151,11 +154,15 @@
            :usocket usocket
            rest)))
 
+;;
+;; The actual compat functions
+
 (defun open-stream (peer-host peer-port
                               &key (local-host :any)
                                    (local-port 0)
                                    (external-format :default)
-                                   (element-type 'character)
+                                   (element-type #-lispworks 'character
+                                                 #+lispworks 'base-char)
                                    (protocol :tcp))
   (unless (eq protocol :tcp)
     (error 'unsupported :feature `(:protocol ,protocol)))
@@ -163,6 +170,48 @@
     (error 'unsupported :feature :bind))
   (unless (eql external-format :default)
     (error 'unsupported :feature :external-format))
-  (let ((socket (socket-connect peer-host peer-port)))
+  (let ((socket (socket-connect peer-host peer-port
+                                :element-type element-type)))
     (wrap-usocket-stream socket)))
 
+
+(defun open-server (&key (host :any)
+                         (port 0)
+                         (reuse-address t)
+                         (backlog 1)
+                         (protocol :tcp))
+  (unless (eq protocol :tcp)
+    (error 'unsupported :feature `(:protocol ,protocol)))
+  (socket-listen (if (eq host :any) *wildcard-host* host)
+                 port
+                 :reuseaddress reuse-address
+                 :backlog backlog))
+
+(defun close-server (server)
+  (socket-close server))
+
+(defun accept-connection (server &key (external-format :default)
+                                 (element-type #-lispworks 'character
+                                               #+lispworks 'base-char))
+  (unless (eql external-format :default)
+    (error 'unsupported :feature :external-format))
+  (wrap-usocket-stream (socket-accept server :element-type element-type)))
+
+(defmacro with-server ((server args) &body forms)
+  (let ((hostsym (gensym))
+        (portsym (gensym))
+        (newargs (gensym)))
+    `(let* ((,hostsym (or (getf ,args :host)
+                          *wildcard-host*))
+            (,portsym (or (getf ,args :port)
+                          *wildcard-port*))
+            (,newargs (copy-list ,args)))
+       (remf ,newargs :host)
+       (remf ,newargs :port)
+       (let ((,server (apply #'socket-listen ,hostsym ,portsym ,newargs)))
+         (when ,server
+           (unwind-protect
+               (progn
+                 , at forms)
+             (when ,server
+               (socket-close ,server))))))))