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

[ehuelsmann at common-lisp.net]

Author: ehuelsmann
Date: Sun Feb 12 14:17:34 2006
New Revision: 84

Modified:
   usocket/trunk/backend/openmcl.lisp
   usocket/trunk/test/test-usocket.lisp
Log:
More OpenMCL fixes.

Modified: usocket/trunk/backend/openmcl.lisp
==============================================================================
--- usocket/trunk/backend/openmcl.lisp	(original)
+++ usocket/trunk/backend/openmcl.lisp	Sun Feb 12 14:17:34 2006
@@ -23,15 +23,20 @@
     (:access-denied . operation-not-permitted-error)))
 
 
+(defun raise-error-from-id (condition-id socket real-condition)
+  (let ((usock-err (cdr (assoc condition-id +openmcl-error-map+))))
+    (if usock-err
+        (error usock-err :socket socket)
+      (error 'unknown-error :socket socket :real-error real-condition)))
+
 (defun handle-condition (condition &optional socket)
   (typecase condition
     (openmcl-socket:socket-error
-     (let ((usock-err
-            (cdr (assoc (openmcl-socket:socket-error-identifier condition)
-                        +openmcl-error-map+))))
-       (if usock-err
-           (error usock-err :socket socket)
-         (error 'unknown-error :socket socket :real-error condition))))
+     (raise-error-from-id (openmcl-socket:socket-error-identifier condition)
+                          socket condition))
+    (ccl::socket-creation-error #| ugh! |#
+     (raise-error-from-id (ccl::socket-creationg-error-idenitifier condition)
+                          socket condition))
     (error (error 'unknown-error :socket socket :real-error condition))
     (condition (signal 'unknown-condition :real-condition condition))))
 

Modified: usocket/trunk/test/test-usocket.lisp
==============================================================================
--- usocket/trunk/test/test-usocket.lisp	(original)
+++ usocket/trunk/test/test-usocket.lisp	Sun Feb 12 14:17:34 2006
@@ -58,10 +58,12 @@
   nil)
 
 (deftest socket-failure.1
-  (with-caught-conditions (#-(or cmu lispworks armedbear)
+  (with-caught-conditions (#-(or cmu lispworks armedbear openmcl)
                              'usocket:network-unreachable-error
                            #+(or cmu lispworks armedbear)
                              'usocket:unknown-error
+                           #+openmcl
+                             'usocket:timeout-error
                            nil)
     (usocket:socket-connect 2130706432 80) ;; == #(127 0 0 0)
     :unreach)
@@ -71,7 +73,9 @@
                              'usocket:unknown-error
                            #+cmu
                              'usocket:network-unreachable-error
-                           #-(or lispworks armedbear cmu)
+                           #+openmcl
+                             'usocket:timeout-error
+                           #-(or lispworks armedbear cmu openmcl)
                              'usocket:host-unreachable-error
                            nil)
       (usocket:socket-connect +non-existing-host+ 80) ;; == #(127 0 0 0)