Author: ctian
Date: Fri Apr 1 06:33:17 2011
New Revision: 630
Log:
[CLISP] rewrite error handling facility.
Modified:
usocket/branches/0.5.x/backend/clisp.lisp
Modified: usocket/branches/0.5.x/backend/clisp.lisp
==============================================================================
--- usocket/branches/0.5.x/backend/clisp.lisp (original)
+++ usocket/branches/0.5.x/backend/clisp.lisp Fri Apr 1 06:33:17 2011
@@ -44,35 +44,74 @@
(mapcar #'host-to-vector-quad
(posix:hostent-addr-list hostent)))))
-#+win32
-(defun remap-maybe-for-win32 (z)
- (mapcar #'(lambda (x)
- (cons (mapcar #'(lambda (y)
- (+ 10000 y))
- (car x))
- (cdr x)))
- z))
-
+;; Format: ((UNIX Windows) . CONDITION)
(defparameter +clisp-error-map+
- #+win32
- (append (remap-maybe-for-win32 +unix-errno-condition-map+)
- (remap-maybe-for-win32 +unix-errno-error-map+))
#-win32
- (append +unix-errno-condition-map+
- +unix-errno-error-map+))
+ `((:EADDRINUSE . address-in-use-error)
+ (:EADDRNOTAVAIL . address-not-available-error)
+ (:EBADF . bad-file-descriptor-error)
+ (:ECONNREFUSED . connection-refused-error)
+ (:ECONNRESET . connection-reset-error)
+ (:ECONNABORTED . connection-aborted-error)
+ (:EINVAL . invalid-argument-error)
+ (:ENOBUFS . no-buffers-error)
+ (:ENOMEM . out-of-memory-error)
+ (:ENOTSUP . operation-not-supported-error)
+ (:EPERM . operation-not-permitted-error)
+ (:EPROTONOSUPPORT . protocol-not-supported-error)
+ (:ESOCKTNOSUPPORT . socket-type-not-supported-error)
+ (:ENETUNREACH . network-unreachable-error)
+ (:ENETDOWN . network-down-error)
+ (:ENETRESET . network-reset-error)
+ (:ESHUTDOWN . already-shutdown-error)
+ (:ETIMEDOUT . timeout-error)
+ (:EHOSTDOWN . host-down-error)
+ (:EHOSTUNREACH . host-unreachable-error))
+ #+win32
+ `((:WSAEADDRINUSE . address-in-use-error)
+ (:WSAEADDRNOTAVAIL . address-not-available-error)
+ (:WSAEBADF . bad-file-descriptor-error)
+ (:WSAECONNREFUSED . connection-refused-error)
+ (:WSAECONNRESET . connection-reset-error)
+ (:WSAECONNABORTED . connection-aborted-error)
+ (:WSAEINVAL . invalid-argument-error)
+ (:WSAENOBUFS . no-buffers-error)
+ (:WSAENOMEM . out-of-memory-error)
+ (:WSAENOTSUP . operation-not-supported-error)
+ (:WSAEPERM . operation-not-permitted-error)
+ (:WSAEPROTONOSUPPORT . protocol-not-supported-error)
+ (:WSAESOCKTNOSUPPORT . socket-type-not-supported-error)
+ (:WSAENETUNREACH . network-unreachable-error)
+ (:WSAENETDOWN . network-down-error)
+ (:WSAENETRESET . network-reset-error)
+ (:WSAESHUTDOWN . already-shutdown-error)
+ (:WSAETIMEDOUT . timeout-error)
+ (:WSAEHOSTDOWN . host-down-error)
+ (:WSAEHOSTUNREACH . host-unreachable-error)))
(defun handle-condition (condition &optional (socket nil))
"Dispatch correct usocket condition."
- (typecase condition
- (system::simple-os-error
- (let ((usock-err
- (cdr (assoc (car (simple-condition-format-arguments condition))
- +clisp-error-map+ :test #'member))))
- (when usock-err ;; don't claim the error if we don't know
- ;; it's actually a socket error ...
- (if (subtypep usock-err 'error)
- (error usock-err :socket socket)
- (signal usock-err :socket socket)))))))
+ (let (error-keyword error-string)
+ (typecase condition
+ (system::simple-os-error
+ (let ((errno (car (simple-condition-format-arguments condition))))
+ (setq error-keyword (os:errno errno)
+ error-string (os:strerror errno))))
+ (simple-error
+ (let ((keyword
+ (car (simple-condition-format-arguments condition))))
+ (setq error-keyword keyword
+ error-string (os:strerror keyword))))
+ (error (error 'unknown-error :real-error condition))
+ (condition (signal 'unknown-condition :real-condition condition)))
+ (when error-keyword
+ (let ((usocket-error
+ (cdr (assoc error-keyword +clisp-error-map+ :test #'eq))))
+ (if usocket-error
+ (if (subtypep usocket-error 'error)
+ (error usocket-error :socket socket)
+ (signal usocket-error :socket socket))
+ (error "Unknown OS error: ~A (~A)" error-string error-keyword))))))
(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
timeout deadline (nodelay t nodelay-specified)
@@ -505,14 +544,19 @@
(rsock_addr (when remote-host
(fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_in)
remote-host (or remote-port local-port)))))
+ (unless (plusp sock)
+ (error "SOCKET-CREATE-DATAGRAM ERROR (socket): ~A" (os:errno)))
(unwind-protect
- (progn
- (%bind sock (ffi:cast (ffi:foreign-value lsock_addr) 'sockaddr)
- *length-of-sockaddr_in*)
+ (let ((rv (%bind sock (ffi:cast (ffi:foreign-value lsock_addr) 'sockaddr)
+ *length-of-sockaddr_in*)))
+ (unless (zerop rv)
+ (error "SOCKET-CREATE-DATAGRAM ERROR (bind): ~A" (os:errno)))
(when rsock_addr
- (%connect sock
- (ffi:cast (ffi:foreign-value rsock_addr) 'sockaddr)
- *length-of-sockaddr_in*)))
+ (let ((rv (%connect sock
+ (ffi:cast (ffi:foreign-value rsock_addr) 'sockaddr)
+ *length-of-sockaddr_in*)))
+ (unless (zerop rv)
+ (error "SOCKET-CREATE-DATAGRAM ERROR (connect): ~A" (os:errno))))))
(ffi:foreign-free lsock_addr)
(when remote-host
(ffi:foreign-free rsock_addr)))
@@ -549,6 +593,8 @@
0 ; flags
(ffi:cast (ffi:foreign-value remote-address) 'sockaddr)
(ffi:foreign-value remote-address-length))
+ (when (minusp n)
+ (error "SOCKET-RECEIVE ERROR: ~A" (os:errno)))
(setq nbytes n)
(when (= address-length *length-of-sockaddr_in*)
(let ((data (sockaddr-sa_data address)))
@@ -561,8 +607,7 @@
(end-2 (min n +max-datagram-packet-size+)))
(replace buffer return-buffer :end1 end-1 :end2 end-2))
(setq buffer (subseq return-buffer 0 (min n +max-datagram-packet-size+))))))
- ((zerop n)) ; do nothing
- (t))) ; TODO: handle error here.
+ ((zerop n))))
(ffi:foreign-free remote-address)
(ffi:foreign-free remote-address-length))
(values buffer nbytes host port)))
@@ -583,23 +628,25 @@
(ffi:allocate-deep 'ffi:uint8 (subseq buffer 0 length) :count length :read-only t)
;; then we allocate the whole buffer directly, that should be faster.
(ffi:allocate-deep 'ffi:uint8 buffer :count (length buffer) :read-only t))))
- nbytes)
+ (real-length (min length +max-datagram-packet-size+))
+ (nbytes 0))
(unwind-protect
(let ((n (if remote-address
(%sendto (socket usocket)
(ffi:foreign-address send-buffer)
- (min length +max-datagram-packet-size+) 0
+ real-length
+ 0 ; flags
(ffi:cast (ffi:foreign-value remote-address) 'sockaddr)
*length-of-sockaddr_in*)
(%send (socket usocket)
- ;; (ffi:cast (ffi:foreign-value send-buffer) 'ffi:c-pointer)
(ffi:foreign-address send-buffer)
- (min length +max-datagram-packet-size+) 0))))
+ real-length
+ 0))))
(cond ((plusp n)
(setq nbytes n))
((zerop n)
(setq nbytes n))
- (t))) ; TODO: error handling
+ (t (error "SOCKET-SEND ERROR: ~A" (os:errno)))))
(ffi:foreign-free send-buffer)
(when remote-address
(ffi:foreign-free remote-address))
@@ -621,7 +668,7 @@
(let ((data (sockaddr-sa_data return-address)))
(setq host (ip-from-octet-buffer data :start 2)
port (port-from-octet-buffer data)))
- (error "get-socket-name error"))) ; TODO: convert this
+ (error "GET-SOCKET-NAME ERROR: ~A" (os:errno))))
(ffi:foreign-free address)
(ffi:foreign-free address-length))
(values (hbo-to-vector-quad host) port)))
