From: Kevin M. Rosenberg <kevin@rosenberg.net>
Date: Tue, 8 Jul 2003 16:12:40 +0000 (+0000)
Subject: r5259: *** empty log message ***
X-Git-Tag: debian-0.6-2~28
X-Git-Url: http://git.kpe.io/?p=cl-modlisp.git;a=commitdiff_plain;h=40b5dce89637f3b90b71ee6ee3932aafa595640b

r5259: *** empty log message ***
---

diff --git a/base.lisp b/base.lisp
index 04cfa38..24c1689 100644
--- a/base.lisp
+++ b/base.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Dec 2002
 ;;;;
-;;;; $Id: base.lisp,v 1.7 2003/07/08 14:00:53 kevin Exp $
+;;;; $Id: base.lisp,v 1.8 2003/07/08 16:12:03 kevin Exp $
 ;;;; *************************************************************************
 
 (in-package #:modlisp)
@@ -17,48 +17,21 @@
 			   (processor-args nil)
 			   (catch-errors t))
   (let ((listener (make-instance 'listener :port port
-				 :name (next-server-name)
+				 :base-name "modlisp"			 
 				 :function 'apache-command-issuer
 				 :function-args (cons processor processor-args)
 				 :format :text
 				 :wait nil
 				 :catch-errors catch-errors)))
-    (handler-case
-	(make-socket-server listener)
-      (error (e)
-	(format t "~&Error while trying to start modlisp server~&  ~A" e)
-	(decf *listener-count*)
-	(values nil nil))
-      (:no-error (res)
-	(declare (ignore res))
-	(push listener *active-listeners*)
-	listener))))
-    
+    (init/listener listener :start)))
+
+
 (defun modlisp-stop (listener)
-  (unless listener
-    (cmsg "listener is NIL in modlisp-stop")
-    (return-from modlisp-stop))
-  (dolist (worker (workers listener))
-    (close-active-socket (connection worker))
-    (destroy-process (process worker)))
-  (setf (workers listener) nil)
-  (with-slots (process socket) listener
-    (errorset (close-passive-socket socket) t)
-    (errorset (destroy-process process) t))
-  (setq *active-listeners* (remove listener *active-listeners*)))
+  (init/listener listener :stop))
 
 (defun modlisp-stop-all ()
-  (dolist (listener *active-listeners*)
-    (ignore-errors
-     (progn
-       (modlisp-stop listener)
-       (setq *active-listeners* (remove listener *active-listeners*))))))
-
-(defun next-server-name ()
-  (format nil "modlisp-socket-server-~d" (incf *listener-count*))) 
+  (stop-all/listener))
 
-(defun next-worker-name ()
-  (format nil "modlisp-worker-~d" (incf *worker-count*)))
 
 (let ((*number-server-requests* 0)
       (*number-worker-requests* 0)
diff --git a/compat.lisp b/compat.lisp
deleted file mode 100644
index e76b7ff..0000000
--- a/compat.lisp
+++ /dev/null
@@ -1,324 +0,0 @@
-;;; -*- Syntax: Ansi-Common-Lisp; Base: 10; Mode: lisp; Package: clit -*-
-;;; $Id: compat.lisp,v 1.3 2003/07/08 12:10:16 kevin Exp $
-
-(in-package #:modlisp)
-
-;; Processes
-
-(defun make-process (name func)
-  #+cmu (mp:make-process func :name name)
-  #+allegro (mp:process-run-function name func)
-  #+lispworks (mp:process-run-function name nil func)
-  #+sb-thread (sb-thread:make-thread func)
-  #+clisp (funcall func)
-  )
-
-(defun destroy-process (process)
-  #+cmu (mp:destroy-process process)
-  #+allegro (mp:process-kill process)
-  #+sbcl-thread (sb-thread:destroy-thread process)
-  #+lispworks (mp:process-kill process)
-  )
-
-(defun make-lock (name)
-  #+allegro (mp:make-process-lock :name name)
-  #+cmu (mp:make-lock name)
-  #+lispworks (mp:make-lock :name name)
-  #+sbcl-thread (sb-thread:make-mutex :name name)
-  )
-
-(defmacro with-lock-held ((lock) &body body)
-  #+allegro
-  `(mp:with-process-lock (,lock) ,@body)
-  #+cmu
-  `(mp:with-lock-held (,lock) ,@body)
-  #+lispworks
-  `(mp:with-lock (,lock) ,@body)
-  #+sbcl-thread
-  `(sb-thread:with-recursive-lock (,lock) ,@body)
-  )
-
-
-;; Sockets
-
-#+lispworks
-(progn
-  
-(define-condition lw-stream-error (error)
-  ((stream :initarg :stream
-           :reader stream-error-stream)
-   (action :initarg :action
-           :reader stream-error-action)
-   (code :initarg :code
-         :reader stream-error-code)
-   (identifier :initarg :identifier
-               :reader stream-error-identifier))
-  (:report (lambda (condition stream)
-             (format stream "A stream error occured (action=~A identifier=~A code=~A stream=~S)."
-                     (stream-error-action condition)
-                     (stream-error-identifier condition)
-                     (stream-error-code condition)
-                     (stream-error-stream condition)))))
-
-(define-condition socket-error (lw-stream-error)
-  ()
-  (:report (lambda (condition stream)
-             (format stream "A socket error occured (action=~A identifier=~A code=~A stream=~S)."
-                     (stream-error-action condition)
-                     (stream-error-identifier condition)
-                     (stream-error-code condition)
-                     (stream-error-stream condition)))))
-
-(defclass socket ()
-    ((passive-socket :type fixnum
-		     :initarg :passive-socket
-		     :reader socket-os-fd)))
-  
-  (defclass passive-socket (socket)
-    ((element-type :type (member signed-byte unsigned-byte base-char)
-		   :initarg :element-type
-		   :reader element-type)
-     (port :type fixnum
-	   :initarg :port
-	   :reader local-port)))
-
-  (defmethod print-object ((passive-socket passive-socket) stream)
-    (print-unreadable-object (passive-socket stream :type t :identity nil)
-      (format stream "@~d on port ~d" (socket-os-fd passive-socket) (local-port passive-socket))))
-
-  (defclass binary-socket-stream (comm:socket-stream) ())
-(defclass input-binary-socket-stream (binary-socket-stream)())
-(defclass output-binary-socket-stream (binary-socket-stream)())
-(defclass bidirectional-binary-socket-stream (input-binary-socket-stream output-binary-socket-stream)())
-
-#+unix
-(defun %socket-error-identifier (code)
-  (case code
-    (32 :x-broken-pipe)
-    (98 :address-in-use)
-    (99 :address-not-available)
-    (100 :network-down)
-    (102 :network-reset)
-    (103 :connection-aborted)
-    (104 :connection-reset)
-    (105 :no-buffer-space)
-    (108 :shutdown)
-    (110 :connection-timed-out)
-    (111 :connection-refused)
-    (112 :host-down)
-    (113 :host-unreachable)
-    (otherwise :unknown)))
-
-#+win32
-(defun %socket-error-identifier (code)
-  (case code
-    (10048 :address-in-use)
-    (10049 :address-not-available)
-    (10050 :network-down)
-    (10052 :network-reset)
-    (10053 :connection-aborted)
-    (10054 :connection-reset)
-    (10055 :no-buffer-space)
-    (10058 :shutdown)
-    (10060 :connection-timed-out)
-    (10061 :connection-refused)
-    (10064 :host-down)
-    (10065 :host-unreachable)
-    (otherwise :unknown)))
-
-(defun socket-error (stream error-code action format-string &rest format-args)
-  (let ((code (if (numberp error-code) error-code #+unix(lw:errno-value))))
-    (error 'socket-error :stream stream :code code
-           :identifier (if (keywordp error-code)
-                           error-code
-                         (%socket-error-identifier error-code))
-           :action action
-           :format-control "~A occured while doing socket IO (~?)"
-           :format-arguments (list 'socket-error format-string format-args))))
-
-
-(defmethod comm::socket-error ((stream binary-socket-stream) error-code format-string &rest format-args)
-  (apply #'socket-error stream error-code :IO format-string format-args))
-
-(defmethod stream-input-available ((fd fixnum))
-  (comm::socket-listen fd))
-
-(defmethod stream-input-available ((stream stream::os-file-handle-stream))
-  (stream-input-available (stream::os-file-handle-stream-file-handle stream)))
-
-(defmethod stream-input-available ((stream comm:socket-stream))
-  (or (comm::socket-listen (comm:socket-stream-socket stream))
-      (listen stream)))
-
-(defmethod stream-input-available ((stream passive-socket))
-  (comm::socket-listen (socket-os-fd stream)))
-
-(defun %new-passive-socket (local-port)
-  (multiple-value-bind (socket error-location error-code)
-      (comm::create-tcp-socket-for-service local-port)
-    (cond (socket socket)
-	  (t (error 'socket-error :action error-location :code error-code :identifier :unknown)))))
-
-) ;; lispworks
-
-#+sbcl
-(defun listen-to-inet-port (&key (port 0) (kind :stream) (reuse nil))
-  "Create, bind and listen to an inet socket on *:PORT.
-setsockopt SO_REUSEADDR if :reuse is not nil"
-  (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
-			       :type :stream
-			       :protocol :tcp)))
-    (if reuse
-        (setf (sb-bsd-sockets:sockopt-reuse-address socket) t))
-    (sb-bsd-sockets:socket-bind 
-     socket (sb-bsd-sockets:make-inet-address "0.0.0.0") port)
-    (sb-bsd-sockets:socket-listen socket 15)
-    socket))
-
-(defun create-inet-listener (port &key (format :text) (reuse-address t))
-  #+cmu (ext:create-inet-listener port)
-  #+allegro
-  (socket:make-socket :connect :passive :local-port port :format :binary
-		      :address-family 
-		      (if (stringp port)
-			  :file
-			(if (or (null port) (integerp port))
-			    :internet
-			  (error "illegal value for port: ~s" port)))
-		      :reuse-address reuse-address)
-  #+sbcl
-  (listen-to-inet-port :port port :reuse reuse-address)
-  #+clisp (ext:socket-server port)
-  #+lispworks
-  (let ((comm::*use_so_reuseaddr* reuse-address))
-    (make-instance 'passive-socket
-		   :port port
-		   :passive-socket (%new-passive-socket port)
-		   :element-type (case format
-				   (:text 'base-char))))
-  )
-
-(defun make-fd-stream (socket &key input output element-type)
-  #+cmu
-  (sys:make-fd-stream socket :input input :output output
-		      :element-type element-type)
-  #+sbcl
-  (sb-bsd-sockets:socket-make-stream socket :input input :output output
-				     :element-type element-type)
-  #-(or cmu sbcl) (declare (ignore input output element-type))
-  #-(or cmu sbcl) socket
-  )
-
-
-(defun accept-tcp-connection (listener)
-  #+cmu
-  (progn
-    (mp:process-wait-until-fd-usable listener :input)
-    (sys:make-fd-stream
-     (nth-value 0 (ext:accept-tcp-connection listener))
-     :input t :output t))
-  #+sbcl
-  (when (sb-sys:wait-until-fd-usable
-	 (sb-bsd-sockets:socket-file-descriptor listener) :input)
-    (sb-bsd-sockets:socket-make-stream 
-     (sb-bsd-sockets:socket-accept listener)
-     :element-type 'base-char
-     :input t :output t))
-  #+allegro
-  (socket:accept-connection listener)
-  #+clisp
-  (ext:socket-accept listener)
-  #+lispworks
-  (progn
-    (loop while (not (stream-input-available listener))
-	  do (sleep 1))
-    (make-instance 'bidirectional-binary-socket-stream
-		   :socket (comm::get-fd-from-socket
-			    (socket-os-fd listener))
-		   :direction :io
-		   :element-type (element-type listener)))
-    
-  )
-
-
-(defmacro errorset (form display)
-  `(handler-case
-    ,form
-    (error (e)
-     (declare (ignorable e))
-     (when ,display
-       (format t "~&Error: ~A~%" e)))))
-
-(defun close-passive-socket (socket)
-  #+allegro (close socket)
-  #+cmu (unix:unix-close socket)
-  #+sbcl (sb-unix:unix-close
-	  (sb-bsd-sockets:socket-file-descriptor socket))
-  #+clisp (close socket)
-  #+lispworks (comm::close-socket (socket-os-fd socket))
-  )
-
-
-(defun close-active-socket (socket)
-  (close socket))
-
-#+sbcl
-(defun ipaddr-to-dotted (ipaddr &key values)
-  "Convert from 32-bit integer to dotted string."
-  (declare (type (unsigned-byte 32) ipaddr))
-  (let ((a (logand #xff (ash ipaddr -24)))
-	(b (logand #xff (ash ipaddr -16)))
-	(c (logand #xff (ash ipaddr -8)))
-	(d (logand #xff ipaddr)))
-    (if values
-	(values a b c d)
-      (format nil "~d.~d.~d.~d" a b c d))))
-
-#+sbcl
-(defun dotted-to-ipaddr (dotted &key (errorp t))
-  "Convert from dotted string to 32-bit integer."
-  (declare (string dotted))
-  (if errorp
-      (let ((ll (string-tokens (substitute #\Space #\. dotted))))
-	(+ (ash (first ll) 24) (ash (second ll) 16)
-	   (ash (third ll) 8) (fourth ll)))
-    (ignore-errors
-	(let ((ll (string-tokens (substitute #\Space #\. dotted))))
-	  (+ (ash (first ll) 24) (ash (second ll) 16)
-	     (ash (third ll) 8) (fourth ll))))))
-
-#+sbcl
-(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
-  (when ignore-cache
-    (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported."))
-  (sb-bsd-sockets:host-ent-name
-   (sb-bsd-sockets:get-host-by-address
-    (sb-bsd-sockets:make-inet-address ipaddr))))
-
-#+sbcl
-(defun lookup-hostname (host &key ignore-cache)
-  (when ignore-cache
-    (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
-  (if (stringp host)
-      (sb-bsd-sockets:host-ent-address
-       (sb-bsd-sockets:get-host-by-name host))
-      (dotted-to-ipaddr (ipaddr-to-dotted host))))
-
-
-(defun make-active-socket (server port)
-  #+allegro (socket:make-socket :remote-host server
-				:remote-port port)
-  #+lispworks (comm:open-tcp-stream server port)
-  #+sbcl (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
-				      :type :stream
-				      :protocol :tcp)))
-	   (sb-bsd-sockets:socket-connect
-	    socket (lookup-hostname server) port)
-	   (sb-bsd-sockets:socket-make-stream socket
-					      :input t
-					      :output t
-					      :element-type 'base-char))
-  #+cmu 
-  (sys:make-fd-stream (ext:connect-to-inet-socket host port)
-		      :input t :output t :element-type 'base-char)
-  )
diff --git a/modlisp.asd b/modlisp.asd
index 790298f..d7f50f9 100644
--- a/modlisp.asd
+++ b/modlisp.asd
@@ -7,13 +7,13 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Dec 2002
 ;;;;
-;;;; $Id: modlisp.asd,v 1.7 2003/07/08 06:40:00 kevin Exp $
+;;;; $Id: modlisp.asd,v 1.8 2003/07/08 16:12:03 kevin Exp $
 ;;;; *************************************************************************
 
 (in-package #:cl-user)
 
 #+(and sbcl (not sb-thread))
-(error "This package requires the multitasking version of sbcl")
+(warn "This package requires the multithreading version of sbcl")
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   #+sbcl (require :sb-bsd-sockets)
@@ -23,19 +23,12 @@
 (defpackage #:modlisp-system (:use #:cl #:asdf))
 (in-package #:modlisp-system)
 
-#+(or allegro clisp cmu lispworks sbcl)
+#+(or allegro clisp cmu lispworks sbcl-thread)
 (defsystem modlisp
     :depends-on (:kmrcl)
     :components
     ((:file "package")
-     (:file "compat" :depends-on ("package"))
      (:file "variables" :depends-on ("package"))
-     (:file #+(or allegro clisp cmu sbcl lispworks) "server"
-;;	    #+lispworks "impl-lispworks"
-	    :depends-on ("compat" "variables"))
-     (:file "base"
-	    :depends-on (#+(or allegro clisp cmu sbcl lispworks) "server"
-;;			   #+lispworks "impl-lispworks"
-			   ))
+     (:file "base" :depends-on ("variables"))
      (:file "utils" :depends-on ("base"))
      (:file "demo" :depends-on ("utils"))))
diff --git a/server.lisp b/server.lisp
deleted file mode 100644
index e3c6775..0000000
--- a/server.lisp
+++ /dev/null
@@ -1,58 +0,0 @@
-;;; -*- Mode:Lisp; Syntax:Common-lisp; Package: modlisp; Base:10 -*-
-
-(in-package #:modlisp)
-
-
-(defun make-socket-server (listener)
-  (setf (socket listener) (create-inet-listener
-			   (port listener)
-			   :format (listener-format listener)))
-  (setf (process listener) (make-process
-			    (name listener)
-			    #'(lambda () (start-socket-server listener))))
-  listener)
-
-
-(defmethod initialize-instance :after
-    ((self worker) &key listener connection name &allow-other-keys)
-  (unless connection
-    (error "connection 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 'thread-fun)
-	#'(lambda ()
-	    (unwind-protect
-		(if (catch-errors listener)
-		    (handler-case
-			(apply (listener-function listener)
-			       connection
-			       (function-args listener))
-		      (error (e)
-			(cmsg "Error ~A [~A]" e name)))
-		  (apply (listener-function listener)
-			 connection
-			 (function-args listener)))
-	  (progn
-	    (errorset (close-active-socket connection) nil)
-	    (cmsg-c :threads "~A ended" name)
-	    (setf (workers listener)
-		  (remove self (workers listener))))))))
-
-(defun start-socket-server (listener)
-  (unwind-protect
-      (loop 
-       (let ((connection (accept-tcp-connection (socket listener))))
-	 (if (wait listener)
-	     (unwind-protect
-		  (apply (listener-function listener)
-			 connection
-			 (function-args listener))
-	       (errorset (close connection) nil))
-	     (let ((worker (make-instance 'worker :listener listener
-					  :connection connection
-					  :name (next-worker-name))))
-	      (setf (process worker)
-		(make-process (name worker) (thread-fun worker)))
-	      (push worker (workers listener))))))
-    (errorset (close-passive-socket (socket listener)) nil)))
diff --git a/variables.lisp b/variables.lisp
index 4e8958a..a4df081 100644
--- a/variables.lisp
+++ b/variables.lisp
@@ -7,17 +7,11 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Dec 2002
 ;;;;
-;;;; $Id: variables.lisp,v 1.6 2003/07/08 14:00:53 kevin Exp $
+;;;; $Id: variables.lisp,v 1.7 2003/07/08 16:12:03 kevin Exp $
 ;;;; *************************************************************************
 
 (in-package #:modlisp)
 
-(defvar *listener-count* 0
-  "used to name listeners")
-
-(defvar *worker-count* 0
-  "used to name workers")
-
 (defconstant +default-apache-port+ 20123
   "Default port for listen")
 
@@ -28,29 +22,7 @@
 (defvar *number-worker-requests* 0)
 (defvar *close-apache-socket* t)
 
-(defclass listener ()
-  ((port :initarg :port :accessor port) 
-   (function :initarg :function :accessor listener-function
-	     :initform nil)
-   (function-args :initarg :function-args :accessor function-args
-		  :initform nil)
-   (process :initarg :process :accessor process)
-   (socket :initarg :socket :accessor socket)
-   (workers :initform nil :accessor workers
-	    :documentation "list of worker threads")
-   (name :initform "" :accessor name :initarg :name)
-   (wait :initform nil :accessor wait :initarg :wait)
-   (catch-errors :initform nil :accessor catch-errors :initarg :catch-errors)
-   (format :initform :text :accessor listener-format :initarg :format)))
-
-(defvar *active-listeners* nil
-    "List of active listeners")
-
-(defclass worker ()
-  ((listener :initarg :listener :accessor listener :initform nil)
-   (connection :initarg :connection :accessor connection :initform nil)
-   (name :initarg :name :accessor name :initform nil)
-   (thread-fun :initarg :thread-fun :accessor thread-fun :initform nil)
-   (process :initarg :process :accessor process :initform nil)))
+
+