X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=listener.lisp;h=80bd362151ccc29cbfd47a510f9ea57fa54a1775;hp=6c511cf9260b08976e2658af04b0ce106f7689f9;hb=3ca593ad0ad02da7ebfd270523795674d6458ad3;hpb=03712fbb06acbb103602bae10f41aeae7fa05127

diff --git a/listener.lisp b/listener.lisp
index 6c511cf..80bd362 100644
--- a/listener.lisp
+++ b/listener.lisp
@@ -1,4 +1,4 @@
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp -*-
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
@@ -7,8 +7,6 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Jun 2003
 ;;;;
-;;;; $Id$
-;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
 ;;;;
 ;;;; KMRCL users are granted the rights to distribute and use this software
@@ -57,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)))
 
 
@@ -112,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)))
@@ -160,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
@@ -187,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)))))))))
@@ -198,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
@@ -217,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)