[usocket-cvs] r47 - usocket/trunk/backend

[ehuelsmann at common-lisp.net]

Author: ehuelsmann
Date: Mon Feb  6 14:51:50 2006
New Revision: 47

Modified:
   usocket/trunk/backend/lispworks.lisp
Log:
Update LispWorks backend.

Modified: usocket/trunk/backend/lispworks.lisp
==============================================================================
--- usocket/trunk/backend/lispworks.lisp	(original)
+++ usocket/trunk/backend/lispworks.lisp	Mon Feb  6 14:51:50 2006
@@ -5,33 +5,59 @@
 
 (in-package :usocket)
 
+
+#+win32
+(defun remap-maybe-for-win32 (z)
+  (mapcar #'(lambda (x)
+              (cons (mapcar #'(lambda (y)
+                                (+ 10000 y))
+                            (car x))
+                    (cdr x)))
+          z))
+
+(defparameter +lispworks-error-map+
+  #+win32
+  (append (remap-for-win32 +unix-errno-condition-map+)
+          (remap-for-win32 +unix-errno-error-map+))
+  #-win32
+  (append +unix-errno-condition-map+
+          +unix-errno-error-map+))
+
+
+
 (defun handle-condition (condition &optional (socket nil))
   "Dispatch correct usocket condition."
   (typecase condition
-    (condition (error 'usocket-error
-                      :real-condition condition
-                      :socket socket))))
+    (simple-error (destructuring-bind (&optional host port err-msg errno)
+                      (simple-condition-format-arguments condition)
+                    (declare (ignore host port err-msg))
+                    (let* ((usock-err
+                            (cdr (assoc errno +lispworks-error-map+
+                                        :test #'member))))
+                      (if usock-err
+                          (if (subtypep usock-err 'error)
+                              (error usock-err :socket socket)
+                            (signal usock-err :socket socket))
+                        (error 'unknown-error
+                               :socket socket
+                               :real-error condition)))))))
+;;     (condition (error 'usocket-error
+;;                       :real-condition condition
+;;                       :socket socket))))
 
-(defun open (host port &optional (type :stream))
+(defun socket-connect (host port &optional (type :stream))
   (declare (ignore type))
-  (make-socket :socket (comm:open-tcp-stream host port)
-               :host host
-               :port port))
-  
-(defmethod close ((socket socket))
-  "Close socket."
-  (cl:close (real-socket socket)))
-
-(defmethod read-line ((socket socket))
-  (cl:read-line (real-socket socket)))
+  (let ((hostname (host-to-hostname host))
+        (stream))
+    (setf stream
+          (with-mapped-conditions ()
+             (comm:open-tcp-stream host port)))
+    (make-socket :socket (comm:socket-stream-socket stream)
+                 :stream stream)))
+;;                 :host host
+;;                 :port port))
 
-(defmethod write-sequence ((socket socket) sequence)
-  (cl:write-sequence sequence (real-socket socket)))
-
-(defun get-host-by-address (address)
-  (comm:get-host-entry (vector-quad-to-dotted-quad address)
-                       :fields '(:name)))
+(defmethod socket-close ((usocket usocket))
+  "Close socket."
+  (close (stream usocket)))
 
-(defun get-host-by-name (name)
-  (mapcar #'hbo-to-vector-quad 
-          (comm:get-host-entry name :fields '(:addresses))))