[usocket-cvs] r64 - in usocket/trunk: . backend

[ehuelsmann at common-lisp.net]

Author: ehuelsmann
Date: Thu Feb  9 16:06:54 2006
New Revision: 64

Added:
   usocket/trunk/backend/armedbear.lisp   (contents, props changed)
   usocket/trunk/backend/openmcl.lisp   (contents, props changed)
Modified:
   usocket/trunk/usocket.asd
   usocket/trunk/usocket.lisp
Log:
Add OpenMCL (untested) and Armedbear (tested with FAILures) support.

Added: usocket/trunk/backend/armedbear.lisp
==============================================================================
--- (empty file)
+++ usocket/trunk/backend/armedbear.lisp	Thu Feb  9 16:06:54 2006
@@ -0,0 +1,24 @@
+;;;; $Id$
+;;;; $URL$
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+
+
+(defun handle-condition (condition &optional socket)
+  (typecase condition
+    (error (error 'unkown-error :socket socket :real-error condition))))
+
+(defun socket-connect (host port)
+  (let ((usock))
+    (with-mapped-conditions (usock)
+       (let ((sock (ext:make-socket (host-to-hostname host) port)))
+         (setf usock
+               (make-socket :socket sock
+                            :stream (ext:get-socket-stream sock)))))))
+
+(defmethod socket-close ((usocket usocket))
+  (with-mapped-conditions (usocket)
+    (ext:socket-close (socket usocket))))

Added: usocket/trunk/backend/openmcl.lisp
==============================================================================
--- (empty file)
+++ usocket/trunk/backend/openmcl.lisp	Thu Feb  9 16:06:54 2006
@@ -0,0 +1,47 @@
+;;;; $Id$
+;;;; $URL$
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+
+
+(defparameter +openmcl-error-map+
+  '((:address-in-use . address-in-use-error)
+    (:connection-aborted . connection-aborted-error)
+    (:no-buffer-space . no-buffers-error)
+    (:connection-timed-out . timeout-error)
+    (:connection-refused . connection-refused-error)
+    (:host-unreachable . host-unreachable-error)
+    (:host-down . host-down-error)
+    (:network-down . network-down-error)
+    (:address-not-available . address-not-available-error)
+    (:network-reset . network-reset-error)
+    (:connection-reset . connection-reset-error)
+    (:shutdown . shutdown-error)
+    (:access-denied . operation-not-permitted-error)))
+
+
+(defun handle-condition (condition &optional socket)
+  (typecase condition
+    (socket-error
+     (let ((usock-err (cdr (assoc (socket-error-identifier condition)
+                                  +openmcl-error-map+))))
+       (if usock-err
+           (error usock-err :socket socket)
+         (error 'unknown-error :socket socket :real-erorr condition))))
+    (error (error 'unknown-error :socket socket :real-erorr condition))
+    (condition (signal 'unkown-condition :real-condition condition))))
+
+(defun socket-connect (host port)
+  (let ((sock))
+    (with-mapped-conditions (sock)
+      (setf sock
+            (make-socket :remote-host (host-to-hostname host)
+                         :remote-port port))
+      (socket-connect sock))))
+
+(defmethod socket-close ((usocket usocket))
+  (with-mapped-conditions (usocket)
+    (close (socket usocket))))

Modified: usocket/trunk/usocket.asd
==============================================================================
--- usocket/trunk/usocket.asd	(original)
+++ usocket/trunk/usocket.asd	Thu Feb  9 16:06:54 2006
@@ -36,4 +36,6 @@
                                   :depends-on ("condition"))
                  #+allegro (:file "allegro" :pathname "backend/allegro"
                                   :depends-on ("condition"))
+                 #+armedbear (:file "armedbear" :pathname "backend/armedbear"
+                                                :depends-on ("condition"))
                  ))

Modified: usocket/trunk/usocket.lisp
==============================================================================
--- usocket/trunk/usocket.lisp	(original)
+++ usocket/trunk/usocket.lisp	Thu Feb  9 16:06:54 2006
@@ -98,29 +98,38 @@
 ;; DNS helper functions
 ;;
 
-#-clisp
-(defun get-host-by-name (name)
-  (let ((hosts (get-hosts-by-name name)))
-    (car hosts)))
-
-#-clisp
-(defun get-random-host-by-name (name)
-  (let ((hosts (get-hosts-by-name name)))
-    (elt hosts (random (length hosts)))))
-
-#-clisp
-(defun host-to-vector-quad (host)
-  "Translate a host specification (vector quad, dotted quad or domain name)
+#-(or clisp openmcl armedbear)
+(progn
+  (defun get-host-by-name (name)
+    (let ((hosts (get-hosts-by-name name)))
+      (car hosts)))
+
+  (defun get-random-host-by-name (name)
+    (let ((hosts (get-hosts-by-name name)))
+      (elt hosts (random (length hosts)))))
+
+  (defun host-to-vector-quad (host)
+    "Translate a host specification (vector quad, dotted quad or domain name)
 to a vector quad."
-  (etypecase host
-    (string (let* ((ip (ignore-errors
-                         (dotted-quad-to-vector-quad host))))
-              (if (and ip (= 4 (length ip)))
-                  ;; valid IP dotted quad?
-                  ip
-                (get-random-host-by-name host))))
-    ((vector t 4) host)
-    (integer (hbo-to-vector-quad host))))
+    (etypecase host
+      (string (let* ((ip (ignore-errors
+                           (dotted-quad-to-vector-quad host))))
+                (if (and ip (= 4 (length ip)))
+                    ;; valid IP dotted quad?
+                    ip
+                  (get-random-host-by-name host))))
+      ((vector t 4) host)
+      (integer (hbo-to-vector-quad host))))
+
+  (defun host-to-hbo (host)
+    (etypecase host
+      (string (let ((ip (ignore-errors
+                          (dotted-quad-to-vector-quad host))))
+                (if (and ip (= 4 (length ip)))
+                    ip
+                  (host-to-hbo (get-host-by-name host)))))
+      ((vector t 4) (host-byte-order host))
+      (integer host))))
 
 (defun host-to-hostname (host)
   "Translate a string or vector quad to a stringified hostname."
@@ -129,17 +138,6 @@
     ((vector t 4) (vector-quad-to-dotted-quad host))
     (integer (hbo-to-dotted-quad host))))
 
-#-clisp
-(defun host-to-hbo (host)
-  (etypecase host
-    (string (let ((ip (ignore-errors
-                        (dotted-quad-to-vector-quad host))))
-              (if (and ip (= 4 (length ip)))
-                  ip
-                (host-to-hbo (get-host-by-name host)))))
-    ((vector t 4) (host-byte-order host))
-    (integer host)))
-
 ;;
 ;; Setting of documentation for backend defined functions
 ;;