[bknr-cvs] hans changed trunk/thirdparty/usocket/

[BKNR Commits]

Revision: 4451
Author: hans
URL: http://bknr.net/trac/changeset/4451

Update from upstream r498
Fix condition instanciation in openmcl port

U   trunk/thirdparty/usocket/backend/openmcl.lisp
U   trunk/thirdparty/usocket/backend/sbcl.lisp
U   trunk/thirdparty/usocket/condition.lisp
U   trunk/thirdparty/usocket/usocket.lisp

Modified: trunk/thirdparty/usocket/backend/openmcl.lisp
===================================================================
--- trunk/thirdparty/usocket/backend/openmcl.lisp	2009-09-02 08:24:18 UTC (rev 4450)
+++ trunk/thirdparty/usocket/backend/openmcl.lisp	2009-09-17 07:01:40 UTC (rev 4451)
@@ -62,9 +62,9 @@
        (raise-error-from-id (openmcl-socket:socket-error-identifier condition)
                             socket condition))
     (ccl:input-timeout
-       (error 'timeout-error :socket socket :real-error condition))
+       (error 'timeout-error :socket socket))
     (ccl:communication-deadline-expired
-       (error 'deadline-error :socket socket :real-error condition))
+       (error 'deadline-error :socket socket))
     (ccl::socket-creation-error #| ugh! |#
        (raise-error-from-id (ccl::socket-creation-error-identifier condition)
                             socket condition))))

Modified: trunk/thirdparty/usocket/backend/sbcl.lisp
===================================================================
--- trunk/thirdparty/usocket/backend/sbcl.lisp	2009-09-02 08:24:18 UTC (rev 4450)
+++ trunk/thirdparty/usocket/backend/sbcl.lisp	2009-09-17 07:01:40 UTC (rev 4451)
@@ -68,7 +68,7 @@
 
   (defun fdset-alloc ()
     (ffi:c-inline () () :pointer-void
-     "cl_alloc_atomic(sizeof(fd_set))" :one-liner t))
+     "ecl_alloc_atomic(sizeof(fd_set))" :one-liner t))
 
   (defun fdset-zero (fdset)
     (ffi:c-inline (fdset) (:pointer-void) :void
@@ -96,7 +96,7 @@
   (defun get-host-name ()
     (ffi:c-inline
      () () :object
-     "{ char *buf = cl_alloc_atomic(257);
+     "{ char *buf = ecl_alloc_atomic(257);
 
         if (gethostname(buf,256) == 0)
           @(return) = make_simple_base_string(buf);
@@ -174,6 +174,8 @@
      . socket-type-not-supported-error)
     (sb-bsd-sockets:network-unreachable-error . network-unreachable-error)
     (sb-bsd-sockets:operation-timeout-error . timeout-error)
+    #-ecl
+    (sb-sys:io-timeout . timeout-error)
     (sb-bsd-sockets:socket-error . ,#'map-socket-error)
 
     ;; Nameservice errors: mapped to unknown-error

Modified: trunk/thirdparty/usocket/condition.lisp
===================================================================
--- trunk/thirdparty/usocket/condition.lisp	2009-09-02 08:24:18 UTC (rev 4450)
+++ trunk/thirdparty/usocket/condition.lisp	2009-09-17 07:01:40 UTC (rev 4451)
@@ -111,6 +111,7 @@
    host-unreachable-error
    shutdown-error
    timeout-error
+   #+openmcl deadline-error
    invalid-socket-error
    invalid-socket-stream-error)
   (socket-error))

Modified: trunk/thirdparty/usocket/usocket.lisp
===================================================================
--- trunk/thirdparty/usocket/usocket.lisp	2009-09-02 08:24:18 UTC (rev 4450)
+++ trunk/thirdparty/usocket/usocket.lisp	2009-09-17 07:01:40 UTC (rev 4451)
@@ -351,6 +351,13 @@
       (push (parse-integer element) new-list))
     new-list))
 
+(defun ip-address-string-p (string)
+  "Return a true value if the given string could be an IP address."
+  (every (lambda (char)
+           (or (digit-char-p char)
+               (eql char #\.)))
+         string))
+
 (defun hbo-to-dotted-quad (integer)
   "Host-byte-order integer to dotted-quad string conversion utility."
   (let ((first (ldb (byte 8 24) integer))
@@ -438,7 +445,7 @@
     "Translate a host specification (vector quad, dotted quad or domain name)
 to a vector quad."
     (etypecase host
-      (string (let* ((ip (ignore-errors
+      (string (let* ((ip (when (ip-address-string-p host)
                            (dotted-quad-to-vector-quad host))))
                 (if (and ip (= 4 (length ip)))
                     ;; valid IP dotted quad?
@@ -451,7 +458,7 @@
 
   (defun host-to-hbo (host)
     (etypecase host
-      (string (let ((ip (ignore-errors
+      (string (let ((ip (when (ip-address-string-p host)
                           (dotted-quad-to-vector-quad host))))
                 (if (and ip (= 4 (length ip)))
                     (host-byte-order ip)