[usocket-cvs] r52 - in usocket/trunk: backend test

[ehuelsmann at common-lisp.net]

Author: ehuelsmann
Date: Mon Feb  6 17:28:51 2006
New Revision: 52

Modified:
   usocket/trunk/backend/cmucl.lisp
   usocket/trunk/test/test-usocket.lisp
Log:
Make CMUCL pass the test-suite.

Modified: usocket/trunk/backend/cmucl.lisp
==============================================================================
--- usocket/trunk/backend/cmucl.lisp	(original)
+++ usocket/trunk/backend/cmucl.lisp	Mon Feb  6 17:28:51 2006
@@ -5,8 +5,8 @@
 
 (in-package :usocket)
 
-
-(defun remap-maybe-for-win32 (z)
+#+win32
+(defun remap-for-win32 (z)
   (mapcar #'(lambda (x)
               (cons (mapcar #'(lambda (y)
                                 (+ 10000 y))
@@ -16,12 +16,22 @@
 
 (defparameter +cmucl-error-map+
   #+win32
-   (append (remap-for-win32 +unix-errno-condition-map+)
+  (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 cmucl-map-socket-error (err &key condition socket)
+  (let ((usock-err
+         (cdr (assoc err +cmucl-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))))
 
 ;; CMUCL error handling is brain-dead: it doesn't preserve any
 ;; information other than the OS error string from which the
@@ -36,17 +46,9 @@
 (defun handle-condition (condition &optional (socket nil))
   "Dispatch correct usocket condition."
   (typecase condition
-    (ext::simple-error
-       (let ((usock-err
-              (cdr (assoc (ext::socket-errno c)
-                          +cmucl-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))))
+    (ext::socket-error (cmucl-map-socket-error (ext::socket-errno condition)
+                                               :socket socket
+                                               :condition condition))
     (simple-error (error 'unknown-error
                          :real-condition condition
                          :socket socket))))
@@ -56,13 +58,16 @@
     (setf socket
           (with-mapped-conditions (socket)
              (ext:connect-to-inet-socket (host-to-hbo host) port type)))
-    (let* ((stream (sys:make-fd-stream socket :input t :output t
-                                       :element-type 'character
-                                       :buffering :full))
-           ;;###FIXME the above line probably needs an :external-format
-           (usocket (make-socket :socket socket
-                                 :host host :port port :stream stream)))
-      usocket)))
+    (if socket
+        (let* ((stream (sys:make-fd-stream socket :input t :output t
+                                           :element-type 'character
+                                           :buffering :full))
+               ;;###FIXME the above line probably needs an :external-format
+               (usocket (make-socket :socket socket
+                                     :stream stream)))
+          usocket)
+      (let ((err (unix:unix-errno)))
+        (when err (cmucl-map-socket-error err))))))
 
 (defmethod socket-close ((usocket usocket))
   "Close socket."
@@ -76,7 +81,7 @@
                  (ext::lookup-host-entry (host-byte-order address)))
     (condition (condition) (handle-condition condition))))
 
-(defun get-host-by-name (name)
+(defun get-hosts-by-name (name)
   (handler-case (mapcar #'hbo-to-vector-quad
                         (ext:host-entry-addr-list
                          (ext:lookup-host-entry name)))

Modified: usocket/trunk/test/test-usocket.lisp
==============================================================================
--- usocket/trunk/test/test-usocket.lisp	(original)
+++ usocket/trunk/test/test-usocket.lisp	Mon Feb  6 17:28:51 2006
@@ -37,10 +37,14 @@
   (catch 'caught-error
     (handler-bind ((usocket:network-unreachable-error
                     #'(lambda (c) (throw 'caught-error nil)))
+                   ;; cmu doesn't report as specific as above
+                   #+cmu
+                   (usocket:unknown-error
+                    #'(lambda (c) (throw 'caught-error nil)))
                    (condition
                     #'(lambda (c) (throw 'caught-error t))))
       (usocket:socket-connect 2130706432 80) ;; == #(127 0 0 0)
-      t))
+      :unreach))
   nil)
 
 ;; let's hope c-l.net doesn't move soon, or that people start to
@@ -50,7 +54,7 @@
     (unwind-protect
         (typep sock 'usocket:usocket)
       (usocket:socket-close sock)))
-  t)
+  t) 
 (deftest socket-connect.2
   (let ((sock (usocket:socket-connect #(65 110 12 237) 80)))
     (unwind-protect