From 3b342ab22c4667bc7b2f0751d4ee57330c3a69d6 Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Fri, 1 Apr 2011 10:48:12 -0600
Subject: [PATCH] Add support for active sockets in listener

---
 ChangeLog        |  4 ++++
 debian/changelog |  6 ++++++
 listener.lisp    | 25 ++++++++++++++++---------
 3 files changed, 26 insertions(+), 9 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 5426a9b..0929de9 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,7 @@
+1 Apr 2011  Kevin Rosenberg <kevin@rosenberg.net>
+	* Version 1.104
+	* listener.lisp: Add support for active sockets in listener
+
 17 Apr 2010  Kevin Rosenberg <kevin@rosenberg.net>
 	* Version 1.102
 	* btree.lisp: New file providing binary tree search for
diff --git a/debian/changelog b/debian/changelog
index 5cd6e8f..79dce9e 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+cl-kmrcl (1.104-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  Fri, 01 Apr 2011 10:47:28 -0600
+
 cl-kmrcl (1.103-1) unstable; urgency=low
 
   * Remove UTF-8 code to allow compilation on CLISP 
diff --git a/listener.lisp b/listener.lisp
index 042d57f..80bd362 100644
--- 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)
-- 
2.34.1