Merge branch 'master' of ssh://git.b9.com/home/gitpub/kmrcl

[kmrcl.git] / listener.lisp

diff --git a/listener.lisp b/listener.lisp
index 042d57fdd6b194fe1636120f2e58d0f03c48ce99..80bd362151ccc29cbfd47a510f9ea57fa54a1775 100644 (file)
--- a/listener.lisp
+++ b/listener.lisp
@@ -55,6 +55,7 @@
 
 (defclass worker (fixed-worker)
   ((connection :initarg :connection :accessor connection :initform nil)
+   (socket :initarg :socket :accessor socket :initform nil)
    (thread-fun :initarg :thread-fun :accessor thread-fun :initform nil)))
 
 
@@ -110,10 +111,11 @@
 (defun listener-shutdown (listener)
   (dolist (worker (workers listener))
     (when (and (typep worker 'worker)
-               (connection worker))
+               (socket worker))
       (errorset (close-active-socket
-                 (connection worker)) nil)
-      (setf (connection worker) nil))
+                 (socket worker)) nil)
+      (setf (connection worker) nil)
+      (setf (socket worker) nil))
     (when (process worker)
       (errorset (destroy-process (process worker)) nil)
       (setf (process worker) nil)))
@@ -158,16 +160,19 @@
 
 
 (defmethod initialize-instance :after
-    ((self worker) &key listener connection name &allow-other-keys)
+    ((self worker) &key listener connection socket name &allow-other-keys)
   (flet ((do-work ()
            (apply (listener-function listener)
                   connection
                   (function-args listener))))
     (unless connection
       (error "connection not provided to modlisp-worker"))
+    (unless socket
+      (error "socket not provided to modlisp-worker"))
     (setf (slot-value self 'listener) listener)
     (setf (slot-value self 'name) name)
     (setf (slot-value self 'connection) connection)
+    (setf (slot-value self 'socket) socket)
     (setf (slot-value self 'thread-fun)
           #'(lambda ()
               (unwind-protect
@@ -185,7 +190,7 @@
                            (do-work)))
                 (progn
                   (errorset (finish-output connection) nil)
-                  (errorset (close-active-socket connection) nil)
+                  (errorset (close-active-socket socket) t)
                   (cmsg-c :threads "~A ended" name)
                   (setf (workers listener)
                         (remove self (workers listener)))))))))
@@ -196,14 +201,15 @@
                (not (funcall (remote-host-checker listener)
                              (remote-host socket))))
       (cmsg-c :thread "Deny connection from ~A" (remote-host conn))
-      (errorset (close-active-socket conn) nil)
-      (setq conn nil))
-    conn))
+      (errorset (close-active-socket socket) nil)
+      (setq conn nil socket nil))
+    (values conn socket)))
 
 (defun start-socket-server (listener)
   (unwind-protect
       (loop
-       (let ((connection (accept-and-check-tcp-connection listener)))
+       (multiple-value-bind (connection socket)
+           (accept-and-check-tcp-connection listener)
          (when connection
            (if (wait listener)
                (unwind-protect
@@ -215,6 +221,7 @@
                    (errorset (close-active-socket connection) nil)))
                (let ((worker (make-instance 'worker :listener listener
                                             :connection connection
+                                            :socket socket
                                             :name (next-worker-name
                                                    (base-name listener)))))
                  (setf (process worker)