Add support for active sockets in listener

diff --git a/ChangeLog b/ChangeLog
index 5426a9be7847488a7389c0b146a8eb6905a922fc..0929de9853662fb903ce9eaa4fa14bd185da76c9 100644 (file)
--- 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 5cd6e8faecbc4815a315668375f8a9bdd4aee56e..79dce9e46a0877f781caaa35ecbf81fe8a3b09f4 100644 (file)
--- 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 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)