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 ;;