handle-condition was incorrect for CLISP. As a result, there were all…

… sorts of socket errors when a remote client closed a connection or we (the server) timed out a socket that we were also blocked reading on.

I've fixed this for Mac and Linux, for CLISP 2.49 and 2.49+ (2010-07-17). So it should continue to work for future versions of CLISP.

I don't have access to Windows, so I don't know if it will work there. I also don't know if it used to work there before my change.

I haven't tested this on client sockets.

----
test set up
;hunchentoot is listening on localhost:8000, like this:
(ql:quickload "hunchentoot")
(use-package "HUNCHENTOOT")
(setf *default-connection-timeout* 5) ;seconds
(define-easy-handler (h1 :uri "/h1") ()
  (setf (content-type*) "text/plain")
  "hallo")
(defparameter *acc* (make-instance 'easy-acceptor :port 8000))
(start *acc*)

test 1
nc localhost 8000
followed immediately by Ctrl-C
clisp should print nothing

test 2
nc localhost 8000
followed by a 5 second wait
should make netcat end
clisp should print nothing

test 3
echo -e 'GET /h1 HTTP/1.0\r\n\r\n' | nc localhost 8000
should print "hallo"
clisp should only print one line showing that the http request was handled

test4
mac: echo | nc localhost 8000
linux: echo | nc -q 1 localhost 8000
clisp should print nothing

----
- = none fail
blank = untested

failing-tests mac linux-2.49 rpi-2.49+-2010-07-17
clisp          -    -           -
sbcl           -    -
ccl            -    -

sbcl
my *default-connection-timeout* hunchentoot setting doesn't seem to take effect.
netcat times out in 20 seconds, not 5.
this is on both mac and linux

backend/clisp.lisp

@@ -66,7 +66,11 @@
     (:ESHUTDOWN . already-shutdown-error)
     (:ETIMEDOUT . timeout-error)
     (:EHOSTDOWN . host-down-error)
-    (:EHOSTUNREACH . host-unreachable-error))
+    (:EHOSTUNREACH . host-unreachable-error)
+    ;; when blocked reading, and we close our socket due to a timeout.
+    ;; POSIX.1 says that EAGAIN and EWOULDBLOCK may have the same values.
+    (:EAGAIN . timeout-error)
+    (:EWOULDBLOCK . timeout-error)) ;linux
   #+win32
   `((:WSAEADDRINUSE . address-in-use-error)
     (:WSAEADDRNOTAVAIL . address-not-available-error)
@@ -89,31 +93,35 @@
     (:WSAEHOSTDOWN . host-down-error)
     (:WSAEHOSTUNREACH . host-unreachable-error)))
 
+(defun parse-errno (condition)
+  "Returns a number or keyword if it can parse what is within parens, else NIL"
+  (let ((s (princ-to-string condition)))
+    (let ((pos1 (position #\( s))
+          (pos2 (position #\) s)))
+      ;mac: number, linux: keyword
+      (ignore-errors
+        (if (digit-char-p (char s (1+ pos1)))
+          (parse-integer s :start (1+ pos1) :end pos2)
+          (let ((*package* (find-package "KEYWORD")))
+            (car (read-from-string s t nil :start pos1 :end (1+ pos2)))))))))
+
 (defun handle-condition (condition &optional (socket nil))
-  "Dispatch correct usocket condition."
-  (let (error-keyword error-string)
-    (typecase condition
-      (ext:os-error
-       (let ((errno (car (simple-condition-format-arguments condition))))
-	 #+ffi
-	 (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)
-	 #+ffi
-	 (setq 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))))))
+  "Dispatch a usocket condition instead of a CLISP specific one, if we can."
+  (let ((errno
+          (cond
+            ;clisp 2.49+
+            ((typep condition (find-symbol "OS-STREAM-ERROR" "EXT"))
+             (parse-errno condition))
+            ;clisp 2.49
+            ((typep condition (find-symbol "SIMPLE-STREAM-ERROR" "SYSTEM"))
+             (car (simple-condition-format-arguments condition))))))
+    (when errno
+      (let ((error-keyword (if (keywordp errno) errno #+ffi(os:errno errno))))
+        (let ((usocket-error (cdr (assoc error-keyword +clisp-error-map+))))
+          (when usocket-error
+            (if (subtypep usocket-error 'error)
+              (error  usocket-error :socket socket)
+              (signal usocket-error :socket socket))))))))
 
 (defun socket-connect (host port &key (protocol :stream) (element-type 'character)
                        timeout deadline (nodelay t nodelay-specified)