bknr-cvs February 2009

bknr-cvs@common-lisp.net

1 participants
139 discussions

[bknr-cvs] edi changed trunk/thirdparty/hunchentoot/packages.lisp
by BKNR Commits 13 Feb '09

13 Feb '09

Revision: 4253 Author: edi URL: http://bknr.net/trac/changeset/4253 Compiles, runs, passes tests on LW U trunk/thirdparty/hunchentoot/packages.lisp Modified: trunk/thirdparty/hunchentoot/packages.lisp =================================================================== --- trunk/thirdparty/hunchentoot/packages.lisp 2009-02-12 23:31:38 UTC (rev 4252) +++ trunk/thirdparty/hunchentoot/packages.lisp 2009-02-12 23:36:48 UTC (rev 4253) @@ -117,6 +117,7 @@ "+HTTP-USE-PROXY+" "+HTTP-VERSION-NOT-SUPPORTED+" "ABORT-REQUEST-HANDLER" + "ACCEPTOR" "ACCEPTOR-ACCESS-LOGGER" "ACCEPTOR-ADDRESS" "ACCEPTOR-HANDLER-SELECTOR"

1 0

[bknr-cvs] edi changed trunk/thirdparty/hunchentoot/
by BKNR Commits 13 Feb '09

13 Feb '09

Revision: 4252 Author: edi URL: http://bknr.net/trac/changeset/4252 Rename file as well D trunk/thirdparty/hunchentoot/connection-dispatcher.lisp U trunk/thirdparty/hunchentoot/hunchentoot.asd A trunk/thirdparty/hunchentoot/taskmaster.lisp Deleted: trunk/thirdparty/hunchentoot/connection-dispatcher.lisp =================================================================== --- trunk/thirdparty/hunchentoot/connection-dispatcher.lisp 2009-02-12 23:30:55 UTC (rev 4251) +++ trunk/thirdparty/hunchentoot/connection-dispatcher.lisp 2009-02-12 23:31:38 UTC (rev 4252) @@ -1,151 +0,0 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10 -*- -;;; $Header$ - -;;; Copyright (c) 2004-2009, Dr. Edmund Weitz. All rights reserved. - -;;; Redistribution and use in source and binary forms, with or without -;;; modification, are permitted provided that the following conditions -;;; are met: - -;;; * Redistributions of source code must retain the above copyright -;;; notice, this list of conditions and the following disclaimer. - -;;; * Redistributions in binary form must reproduce the above -;;; copyright notice, this list of conditions and the following -;;; disclaimer in the documentation and/or other materials -;;; provided with the distribution. - -;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED -;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY -;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE -;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(in-package :hunchentoot) - -(defclass taskmaster () - ((acceptor :accessor taskmaster-acceptor - :documentation "The acceptor instance that this -taskmaster works for.")) - (:documentation "Base class for all taskmaster classes. Its purpose -is to carry the back pointer to the acceptor instance.")) - -(defgeneric execute-acceptor (taskmaster) - (:documentation - "This function is called once Hunchentoot has performed all initial -processing to start listening for incoming connections. It does so by -calling the ACCEPT-CONNECTIONS functions of the acceptor, taken from -the ACCEPTOR slot of the taskmaster instance. - -In a multi-threaded environment, the taskmaster starts a new -thread and calls THUNK in that thread. In a single-threaded -environment, the thunk will be called directly.")) - -(defgeneric handle-incoming-connection (taskmaster socket) - (:documentation - "This function is called by Hunchentoot to start processing of -requests on a new incoming connection. SOCKET is the usocket instance -that represents the new connection \(or a socket handle on LispWorks). -The taskmaster starts processing requests on the incoming -connection by calling the START-REQUEST-PROCESSING function of the -acceptor instance, taken from the ACCEPTOR slot in the taskmaster -instance. The SOCKET argument is passed to START-REQUEST-PROCESSING -as argument. - -In a multi-threaded environment, the taskmaster runs this function -in a separate thread. In a single-threaded environment, this function -is called directly.")) - -(defgeneric shutdown (taskmaster) - (:documentation "Terminate all threads that are currently associated -with the taskmaster, if any.")) - -(defclass single-threaded-taskmaster (taskmaster) - () - (:documentation "Taskmaster that runs synchronously in the -thread that invoked the START-SERVER function.")) - -(defmethod execute-acceptor ((taskmaster single-threaded-taskmaster)) - (accept-connections (taskmaster-acceptor taskmaster))) - -(defmethod handle-incoming-connection ((taskmaster single-threaded-taskmaster) socket) - (process-connection (taskmaster-acceptor taskmaster) socket)) - -(defclass one-thread-per-taskmaster (taskmaster) - ((acceptor-process :accessor acceptor-process - :documentation "Process that accepts incoming -connections and hands them off to new processes for request -handling.")) - (:documentation "Taskmaster that starts one thread for -listening to incoming requests and one thread for each incoming -connection.")) - -;; usocket implementation - -#-:lispworks -(defmethod shutdown ((taskmaster taskmaster))) - -#-:lispworks -(defmethod shutdown ((taskmaster one-thread-per-taskmaster)) - ;; just wait until the acceptor process has finished, then return - (loop - (unless (bt:thread-alive-p (acceptor-process taskmaster)) - (return)) - (sleep 1))) - -#-:lispworks -(defmethod execute-acceptor ((taskmaster one-thread-per-taskmaster)) - (setf (acceptor-process taskmaster) - (bt:make-thread (lambda () - (accept-connections (taskmaster-acceptor taskmaster))) - :name (format nil "Hunchentoot acceptor \(~A:~A)" - (or (acceptor-address (taskmaster-acceptor taskmaster)) "*") - (acceptor-port (taskmaster-acceptor taskmaster)))))) - -#-:lispworks -(defun client-as-string (socket) - (let ((address (usocket:get-peer-address socket)) - (port (usocket:get-peer-port socket))) - (when (and address port) - (format nil "~A:~A" - (usocket:vector-quad-to-dotted-quad address) - port)))) - -#-:lispworks -(defmethod handle-incoming-connection ((taskmaster one-thread-per-taskmaster) socket) - (bt:make-thread (lambda () - (process-connection (taskmaster-acceptor taskmaster) socket)) - :name (format nil "Hunchentoot worker \(client: ~A)" (client-as-string socket)))) - -;; LispWorks implementation - -#+:lispworks -(defmethod shutdown ((taskmaster taskmaster)) - (when-let (process (acceptor-process (taskmaster-acceptor taskmaster))) - ;; kill the main acceptor process, see LW documentation for - ;; COMM:START-UP-SERVER - (mp:process-kill process))) - -#+:lispworks -(defmethod execute-acceptor ((taskmaster one-thread-per-taskmaster)) - (accept-connections (taskmaster-acceptor taskmaster))) - -#+:lispworks -(defmethod handle-incoming-connection ((taskmaster one-thread-per-taskmaster) handle) - (incf *worker-counter*) - ;; check if we need to perform a global GC - (when (and *cleanup-interval* - (zerop (mod *worker-counter* *cleanup-interval*))) - (when *cleanup-function* - (funcall *cleanup-function*))) - (mp:process-run-function (format nil "Hunchentoot worker \(client: ~{~A:~A~})" - (multiple-value-list - (get-peer-address-and-port handle))) - nil #'process-connection - (taskmaster-acceptor taskmaster) handle)) Modified: trunk/thirdparty/hunchentoot/hunchentoot.asd =================================================================== --- trunk/thirdparty/hunchentoot/hunchentoot.asd 2009-02-12 23:30:55 UTC (rev 4251) +++ trunk/thirdparty/hunchentoot/hunchentoot.asd 2009-02-12 23:31:38 UTC (rev 4252) @@ -76,6 +76,6 @@ (:file "easy-handlers") (:file "headers") (:file "set-timeouts") - (:file "connection-dispatcher") + (:file "taskmaster") (:file "acceptor") #-:hunchentoot-no-ssl (:file "ssl"))) Copied: trunk/thirdparty/hunchentoot/taskmaster.lisp (from rev 4251, trunk/thirdparty/hunchentoot/connection-dispatcher.lisp) =================================================================== --- trunk/thirdparty/hunchentoot/taskmaster.lisp (rev 0) +++ trunk/thirdparty/hunchentoot/taskmaster.lisp 2009-02-12 23:31:38 UTC (rev 4252) @@ -0,0 +1,151 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10 -*- +;;; $Header$ + +;;; Copyright (c) 2004-2009, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :hunchentoot) + +(defclass taskmaster () + ((acceptor :accessor taskmaster-acceptor + :documentation "The acceptor instance that this +taskmaster works for.")) + (:documentation "Base class for all taskmaster classes. Its purpose +is to carry the back pointer to the acceptor instance.")) + +(defgeneric execute-acceptor (taskmaster) + (:documentation + "This function is called once Hunchentoot has performed all initial +processing to start listening for incoming connections. It does so by +calling the ACCEPT-CONNECTIONS functions of the acceptor, taken from +the ACCEPTOR slot of the taskmaster instance. + +In a multi-threaded environment, the taskmaster starts a new +thread and calls THUNK in that thread. In a single-threaded +environment, the thunk will be called directly.")) + +(defgeneric handle-incoming-connection (taskmaster socket) + (:documentation + "This function is called by Hunchentoot to start processing of +requests on a new incoming connection. SOCKET is the usocket instance +that represents the new connection \(or a socket handle on LispWorks). +The taskmaster starts processing requests on the incoming +connection by calling the START-REQUEST-PROCESSING function of the +acceptor instance, taken from the ACCEPTOR slot in the taskmaster +instance. The SOCKET argument is passed to START-REQUEST-PROCESSING +as argument. + +In a multi-threaded environment, the taskmaster runs this function +in a separate thread. In a single-threaded environment, this function +is called directly.")) + +(defgeneric shutdown (taskmaster) + (:documentation "Terminate all threads that are currently associated +with the taskmaster, if any.")) + +(defclass single-threaded-taskmaster (taskmaster) + () + (:documentation "Taskmaster that runs synchronously in the +thread that invoked the START-SERVER function.")) + +(defmethod execute-acceptor ((taskmaster single-threaded-taskmaster)) + (accept-connections (taskmaster-acceptor taskmaster))) + +(defmethod handle-incoming-connection ((taskmaster single-threaded-taskmaster) socket) + (process-connection (taskmaster-acceptor taskmaster) socket)) + +(defclass one-thread-per-taskmaster (taskmaster) + ((acceptor-process :accessor acceptor-process + :documentation "Process that accepts incoming +connections and hands them off to new processes for request +handling.")) + (:documentation "Taskmaster that starts one thread for +listening to incoming requests and one thread for each incoming +connection.")) + +;; usocket implementation + +#-:lispworks +(defmethod shutdown ((taskmaster taskmaster))) + +#-:lispworks +(defmethod shutdown ((taskmaster one-thread-per-taskmaster)) + ;; just wait until the acceptor process has finished, then return + (loop + (unless (bt:thread-alive-p (acceptor-process taskmaster)) + (return)) + (sleep 1))) + +#-:lispworks +(defmethod execute-acceptor ((taskmaster one-thread-per-taskmaster)) + (setf (acceptor-process taskmaster) + (bt:make-thread (lambda () + (accept-connections (taskmaster-acceptor taskmaster))) + :name (format nil "Hunchentoot acceptor \(~A:~A)" + (or (acceptor-address (taskmaster-acceptor taskmaster)) "*") + (acceptor-port (taskmaster-acceptor taskmaster)))))) + +#-:lispworks +(defun client-as-string (socket) + (let ((address (usocket:get-peer-address socket)) + (port (usocket:get-peer-port socket))) + (when (and address port) + (format nil "~A:~A" + (usocket:vector-quad-to-dotted-quad address) + port)))) + +#-:lispworks +(defmethod handle-incoming-connection ((taskmaster one-thread-per-taskmaster) socket) + (bt:make-thread (lambda () + (process-connection (taskmaster-acceptor taskmaster) socket)) + :name (format nil "Hunchentoot worker \(client: ~A)" (client-as-string socket)))) + +;; LispWorks implementation + +#+:lispworks +(defmethod shutdown ((taskmaster taskmaster)) + (when-let (process (acceptor-process (taskmaster-acceptor taskmaster))) + ;; kill the main acceptor process, see LW documentation for + ;; COMM:START-UP-SERVER + (mp:process-kill process))) + +#+:lispworks +(defmethod execute-acceptor ((taskmaster one-thread-per-taskmaster)) + (accept-connections (taskmaster-acceptor taskmaster))) + +#+:lispworks +(defmethod handle-incoming-connection ((taskmaster one-thread-per-taskmaster) handle) + (incf *worker-counter*) + ;; check if we need to perform a global GC + (when (and *cleanup-interval* + (zerop (mod *worker-counter* *cleanup-interval*))) + (when *cleanup-function* + (funcall *cleanup-function*))) + (mp:process-run-function (format nil "Hunchentoot worker \(client: ~{~A:~A~})" + (multiple-value-list + (get-peer-address-and-port handle))) + nil #'process-connection + (taskmaster-acceptor taskmaster) handle))

1 0

[bknr-cvs] edi changed trunk/thirdparty/hunchentoot/
by BKNR Commits 13 Feb '09

13 Feb '09

Revision: 4251 Author: edi URL: http://bknr.net/trac/changeset/4251 Rename U trunk/thirdparty/hunchentoot/acceptor.lisp U trunk/thirdparty/hunchentoot/connection-dispatcher.lisp U trunk/thirdparty/hunchentoot/packages.lisp Modified: trunk/thirdparty/hunchentoot/acceptor.lisp =================================================================== --- trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-12 23:09:58 UTC (rev 4250) +++ trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-12 23:30:55 UTC (rev 4251) @@ -50,11 +50,10 @@ used by this acceptor. A function which accepts a REQUEST object and calls a request handler of its choice \(and returns its return value).") - (connection-dispatcher :initarg :connection-dispatcher - :reader acceptor-connection-dispatcher - :documentation "The connection dispatcher that is -responsible for listening to new connections and scheduling them for -execution.") + (taskmaster :initarg :taskmaster + :reader acceptor-taskmaster + :documentation "The taskmaster that is responsible for +scheduling the work for this acceptor.") (output-chunking-p :initarg :output-chunking-p :accessor acceptor-output-chunking-p :documentation "Whether the acceptor may use output chunking.") @@ -124,8 +123,8 @@ :name (gensym) :request-class 'request :handler-selector 'list-handler-selector - :connection-dispatcher (make-instance (cond (*supports-threads-p* 'one-thread-per-connection-dispatcher) - (t 'single-threaded-connection-dispatcher))) + :taskmaster (make-instance (cond (*supports-threads-p* 'one-thread-per-taskmaster) + (t 'single-threaded-taskmaster))) :output-chunking-p t :input-chunking-p t :persistent-connections-p t @@ -157,9 +156,9 @@ in use' or similar).")) (defgeneric accept-connections (acceptor) - (:documentation "In a loop, accepts a connection and -dispatches it to the acceptor's connection dispatcher object for processing -using HANDLE-INCOMING-CONNECTION.")) + (:documentation "In a loop, accepts a connection and dispatches it +to the acceptor's taskmaster for processing using +HANDLE-INCOMING-CONNECTION.")) (defgeneric initialize-connection-stream (acceptor stream) (:documentation "Wraps the given STREAM with all the additional @@ -174,13 +173,12 @@ the stream.")) (defgeneric process-connection (acceptor socket) - (:documentation "This function is called by the connection -dispatcher when a new client connection has been established. -Arguments are the ACCEPTOR object and a usocket socket stream object -\(or a LispWorks socket handle) in SOCKET. It reads the request -headers and hands over to PROCESS-REQUEST. This is done in a loop -until the stream has to be closed or until a connection timeout -occurs.")) + (:documentation "This function is called by the taskmaster when a +new client connection has been established. Arguments are the +ACCEPTOR object and a usocket socket stream object \(or a LispWorks +socket handle) in SOCKET. It reads the request headers and hands over +to PROCESS-REQUEST. This is done in a loop until the stream has to be +closed or until a connection timeout occurs.")) (defgeneric acceptor-ssl-p (acceptor) (:documentation "Returns a true value if ACCEPTOR uses SSL @@ -197,14 +195,14 @@ (defmethod start ((acceptor acceptor)) (start-listening acceptor) - (let ((connection-dispatcher (acceptor-connection-dispatcher acceptor))) - (setf (acceptor connection-dispatcher) acceptor) - (execute-acceptor connection-dispatcher)) + (let ((taskmaster (acceptor-taskmaster acceptor))) + (setf (taskmaster-acceptor taskmaster) acceptor) + (execute-acceptor taskmaster)) acceptor) (defmethod stop ((acceptor acceptor)) (setf (acceptor-shutdown-p acceptor) t) - (shutdown (acceptor-connection-dispatcher acceptor)) + (shutdown (acceptor-taskmaster acceptor)) #-:lispworks (usocket:socket-close (acceptor-listen-socket acceptor))) @@ -228,7 +226,7 @@ (defmethod process-connection :around ((*acceptor* acceptor) (socket t)) "The around method is responsible for error handling." (declare (ignore socket)) - ;; note that this call also binds *ACCEPTOR* + ;; note that this method also binds *ACCEPTOR* (handler-bind ((error ;; abort if there's an error which isn't caught inside (lambda (cond) @@ -299,8 +297,9 @@ (defun process-request (request) "This function is called by PROCESS-CONNECTION after the incoming headers have been read. It sets up the REQUEST and REPLY objects, -dispatches to a handler, and finally sends the output to the client -using START-OUTPUT. If all goes as planned, the function returns T." +selects and calls a handler, and finally sends the output to the +client using START-OUTPUT. If all goes as planned, the function +returns T." (let (*tmp-files* *headers-sent*) (unwind-protect (let* ((*request* request)) @@ -369,7 +368,7 @@ (set-timeouts client-connection (acceptor-read-timeout acceptor) (acceptor-write-timeout acceptor)) - (handle-incoming-connection (acceptor-connection-dispatcher acceptor) + (handle-incoming-connection (acceptor-taskmaster acceptor) client-connection)) ;; ignore condition (usocket:connection-aborted-error ())))))) @@ -395,7 +394,7 @@ :function (lambda (handle) (unless (acceptor-shutdown-p acceptor) (handle-incoming-connection - (acceptor-connection-dispatcher acceptor) handle))) + (acceptor-taskmaster acceptor) handle))) ;; wait until the acceptor was successfully started ;; or an error condition is returned :wait t) Modified: trunk/thirdparty/hunchentoot/connection-dispatcher.lisp =================================================================== --- trunk/thirdparty/hunchentoot/connection-dispatcher.lisp 2009-02-12 23:09:58 UTC (rev 4250) +++ trunk/thirdparty/hunchentoot/connection-dispatcher.lisp 2009-02-12 23:30:55 UTC (rev 4251) @@ -29,84 +29,84 @@ (in-package :hunchentoot) -(defclass connection-dispatcher () - ((acceptor :accessor acceptor +(defclass taskmaster () + ((acceptor :accessor taskmaster-acceptor :documentation "The acceptor instance that this -connection dispatcher works for.")) - (:documentation "Base class for all connection dispatchers classes. -Its purpose is to carry the back pointer to the acceptor instance.")) +taskmaster works for.")) + (:documentation "Base class for all taskmaster classes. Its purpose +is to carry the back pointer to the acceptor instance.")) -(defgeneric execute-acceptor (connection-dispatcher) +(defgeneric execute-acceptor (taskmaster) (:documentation "This function is called once Hunchentoot has performed all initial processing to start listening for incoming connections. It does so by calling the ACCEPT-CONNECTIONS functions of the acceptor, taken from -the ACCEPTOR slot of the connection dispatcher instance. +the ACCEPTOR slot of the taskmaster instance. -In a multi-threaded environment, the connection dispatcher starts a new +In a multi-threaded environment, the taskmaster starts a new thread and calls THUNK in that thread. In a single-threaded environment, the thunk will be called directly.")) -(defgeneric handle-incoming-connection (connection-dispatcher socket) +(defgeneric handle-incoming-connection (taskmaster socket) (:documentation "This function is called by Hunchentoot to start processing of requests on a new incoming connection. SOCKET is the usocket instance that represents the new connection \(or a socket handle on LispWorks). -The connection dispatcher starts processing requests on the incoming +The taskmaster starts processing requests on the incoming connection by calling the START-REQUEST-PROCESSING function of the -acceptor instance, taken from the ACCEPTOR slot in the connection dispatcher +acceptor instance, taken from the ACCEPTOR slot in the taskmaster instance. The SOCKET argument is passed to START-REQUEST-PROCESSING as argument. -In a multi-threaded environment, the connection dispatcher runs this function +In a multi-threaded environment, the taskmaster runs this function in a separate thread. In a single-threaded environment, this function is called directly.")) -(defgeneric shutdown (connection-dispatcher) +(defgeneric shutdown (taskmaster) (:documentation "Terminate all threads that are currently associated -with the connection dispatcher, if any.")) +with the taskmaster, if any.")) -(defclass single-threaded-connection-dispatcher (connection-dispatcher) +(defclass single-threaded-taskmaster (taskmaster) () - (:documentation "Connection Dispatcher that runs synchronously in the + (:documentation "Taskmaster that runs synchronously in the thread that invoked the START-SERVER function.")) -(defmethod execute-acceptor ((dispatcher single-threaded-connection-dispatcher)) - (accept-connections (acceptor dispatcher))) +(defmethod execute-acceptor ((taskmaster single-threaded-taskmaster)) + (accept-connections (taskmaster-acceptor taskmaster))) -(defmethod handle-incoming-connection ((dispatcher single-threaded-connection-dispatcher) socket) - (process-connection (acceptor dispatcher) socket)) +(defmethod handle-incoming-connection ((taskmaster single-threaded-taskmaster) socket) + (process-connection (taskmaster-acceptor taskmaster) socket)) -(defclass one-thread-per-connection-dispatcher (connection-dispatcher) +(defclass one-thread-per-taskmaster (taskmaster) ((acceptor-process :accessor acceptor-process :documentation "Process that accepts incoming -connections and dispatches them to new processes for request -execution.")) - (:documentation "Connection Dispatcher that starts one thread for +connections and hands them off to new processes for request +handling.")) + (:documentation "Taskmaster that starts one thread for listening to incoming requests and one thread for each incoming connection.")) ;; usocket implementation #-:lispworks -(defmethod shutdown ((dispatcher connection-dispatcher))) +(defmethod shutdown ((taskmaster taskmaster))) #-:lispworks -(defmethod shutdown ((dispatcher one-thread-per-connection-dispatcher)) +(defmethod shutdown ((taskmaster one-thread-per-taskmaster)) ;; just wait until the acceptor process has finished, then return (loop - (unless (bt:thread-alive-p (acceptor-process dispatcher)) + (unless (bt:thread-alive-p (acceptor-process taskmaster)) (return)) (sleep 1))) #-:lispworks -(defmethod execute-acceptor ((dispatcher one-thread-per-connection-dispatcher)) - (setf (acceptor-process dispatcher) +(defmethod execute-acceptor ((taskmaster one-thread-per-taskmaster)) + (setf (acceptor-process taskmaster) (bt:make-thread (lambda () - (accept-connections (acceptor dispatcher))) + (accept-connections (taskmaster-acceptor taskmaster))) :name (format nil "Hunchentoot acceptor \(~A:~A)" - (or (acceptor-address (acceptor dispatcher)) "*") - (acceptor-port (acceptor dispatcher)))))) + (or (acceptor-address (taskmaster-acceptor taskmaster)) "*") + (acceptor-port (taskmaster-acceptor taskmaster)))))) #-:lispworks (defun client-as-string (socket) @@ -118,26 +118,26 @@ port)))) #-:lispworks -(defmethod handle-incoming-connection ((dispatcher one-thread-per-connection-dispatcher) socket) +(defmethod handle-incoming-connection ((taskmaster one-thread-per-taskmaster) socket) (bt:make-thread (lambda () - (process-connection (acceptor dispatcher) socket)) + (process-connection (taskmaster-acceptor taskmaster) socket)) :name (format nil "Hunchentoot worker \(client: ~A)" (client-as-string socket)))) ;; LispWorks implementation #+:lispworks -(defmethod shutdown ((dispatcher connection-dispatcher)) - (when-let (process (acceptor-process (acceptor dispatcher))) +(defmethod shutdown ((taskmaster taskmaster)) + (when-let (process (acceptor-process (taskmaster-acceptor taskmaster))) ;; kill the main acceptor process, see LW documentation for ;; COMM:START-UP-SERVER (mp:process-kill process))) #+:lispworks -(defmethod execute-acceptor ((dispatcher one-thread-per-connection-dispatcher)) - (accept-connections (acceptor dispatcher))) +(defmethod execute-acceptor ((taskmaster one-thread-per-taskmaster)) + (accept-connections (taskmaster-acceptor taskmaster))) #+:lispworks -(defmethod handle-incoming-connection ((dispatcher one-thread-per-connection-dispatcher) handle) +(defmethod handle-incoming-connection ((taskmaster one-thread-per-taskmaster) handle) (incf *worker-counter*) ;; check if we need to perform a global GC (when (and *cleanup-interval* @@ -148,4 +148,4 @@ (multiple-value-list (get-peer-address-and-port handle))) nil #'process-connection - (acceptor dispatcher) handle)) + (taskmaster-acceptor taskmaster) handle)) Modified: trunk/thirdparty/hunchentoot/packages.lisp =================================================================== --- trunk/thirdparty/hunchentoot/packages.lisp 2009-02-12 23:09:58 UTC (rev 4250) +++ trunk/thirdparty/hunchentoot/packages.lisp 2009-02-12 23:30:55 UTC (rev 4251) @@ -117,7 +117,6 @@ "+HTTP-USE-PROXY+" "+HTTP-VERSION-NOT-SUPPORTED+" "ABORT-REQUEST-HANDLER" - "ACCEPTOR" "ACCEPTOR-ACCESS-LOGGER" "ACCEPTOR-ADDRESS" "ACCEPTOR-HANDLER-SELECTOR" @@ -150,7 +149,6 @@ "COOKIES-IN" "COOKIES-IN*" "COOKIES-OUT" - "CONNECTION-DISPATCHER" "CREATE-FOLDER-DISPATCHER-AND-HANDLER" "CREATE-PREFIX-DISPATCHER" "CREATE-REGEX-DISPATCHER" @@ -239,6 +237,8 @@ "START-LISTENING" "START-SESSION" "STOP" + "TASKMASTER" + "TASKMASTER-ACCEPTOR" "URL-DECODE" "URL-ENCODE" "USER-AGENT"))

1 0

[bknr-cvs] edi changed trunk/thirdparty/hunchentoot/
by BKNR Commits 13 Feb '09

13 Feb '09

Revision: 4250 Author: edi URL: http://bknr.net/trac/changeset/4250 Checkpoint U trunk/thirdparty/hunchentoot/acceptor.lisp U trunk/thirdparty/hunchentoot/misc.lisp U trunk/thirdparty/hunchentoot/packages.lisp U trunk/thirdparty/hunchentoot/request.lisp U trunk/thirdparty/hunchentoot/specials.lisp U trunk/thirdparty/hunchentoot/test/test-handlers.lisp Modified: trunk/thirdparty/hunchentoot/acceptor.lisp =================================================================== --- trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-12 22:33:37 UTC (rev 4249) +++ trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-12 23:09:58 UTC (rev 4250) @@ -44,10 +44,12 @@ :documentation "Determines which class of request objects is created when a request comes in and should be \(a symbol naming) a class which inherits from REQUEST.") - (request-dispatcher :initarg :request-dispatcher - :accessor acceptor-request-dispatcher - :documentation "The dispatcher function used by -this acceptor.") + (handler-selector :initarg :handler-selector + :accessor acceptor-handler-selector + :documentation "The handler selector function +used by this acceptor. A function which accepts a REQUEST object and +calls a request handler of its choice \(and returns its return +value).") (connection-dispatcher :initarg :connection-dispatcher :reader acceptor-connection-dispatcher :documentation "The connection dispatcher that is @@ -121,7 +123,7 @@ :port 80 :name (gensym) :request-class 'request - :request-dispatcher 'dispatch-request + :handler-selector 'list-handler-selector :connection-dispatcher (make-instance (cond (*supports-threads-p* 'one-thread-per-connection-dispatcher) (t 'single-threaded-connection-dispatcher))) :output-chunking-p t @@ -322,7 +324,7 @@ ;; skip dispatch if bad request (when (eql (return-code) +http-ok+) ;; now do the work - (funcall (acceptor-request-dispatcher *acceptor*) *request* *reply*)))) + (funcall (acceptor-handler-selector *acceptor*) *request*)))) (when error (setf (return-code *reply*) +http-internal-server-error+)) @@ -406,12 +408,12 @@ (defmethod accept-connections ((acceptor acceptor)) (mp:process-unstop (acceptor-process acceptor))) -;;; TODO -(defgeneric dispatch-request (request reply) - (:documentation "") - (:method (request reply) - (loop for dispatcher in *dispatch-table* - for action = (funcall dispatcher request) - when action return (funcall action) - finally (setf (return-code reply) +http-not-found+)))) +(defun list-handler-selector (request) + "The default handler selector which selects a request handler based +on a list of individual request dispatchers all of which can either +return a handler or neglect by returning NIL." + (loop for dispatcher in *dispatch-table* + for action = (funcall dispatcher request) + when action return (funcall action) + finally (setf (return-code *reply*) +http-not-found+))) Modified: trunk/thirdparty/hunchentoot/misc.lisp =================================================================== --- trunk/thirdparty/hunchentoot/misc.lisp 2009-02-12 22:33:37 UTC (rev 4249) +++ trunk/thirdparty/hunchentoot/misc.lisp 2009-02-12 23:09:58 UTC (rev 4250) @@ -128,6 +128,12 @@ (and (scan scanner (script-name request)) handler)))) +(defun abort-request-handler (&optional result) + "This function can be called by a request handler at any time to +immediately abort handling the request. This works as if the handler +had returned RESULT. See the source code of REDIRECT for an example." + (throw 'handler-done result)) + (defun handle-static-file (path &optional content-type) "A function which acts like a Hunchentoot handler for the file denoted by PATH. Send a content type header corresponding to @@ -138,7 +144,7 @@ (fad:directory-exists-p path)) ;; does not exist (setf (return-code) +http-not-found+) - (throw 'handler-done nil)) + (abort-request-handler)) (let ((time (or (file-write-date path) (get-universal-time)))) (setf (content-type) (or content-type (mime-type path) @@ -203,7 +209,7 @@ (loop for component in (rest script-path-directory) always (stringp component)))) (setf (return-code) +http-forbidden+) - (throw 'handler-done nil)) + (abort-request-handler)) (handle-static-file (merge-pathnames script-path base-path) content-type)))) (create-prefix-dispatcher uri-prefix #'handler))) @@ -248,7 +254,7 @@ (setq url (add-cookie-value-to-url url :replace-ampersands-p nil))) (setf (header-out :location) url (return-code *reply*) code) - (throw 'handler-done nil))) + (abort-request-handler))) (defun require-authorization (&optional (realm "Hunchentoot")) "Sends back appropriate headers to require basic HTTP authentication @@ -257,4 +263,4 @@ (format nil "Basic realm=\"~A\"" (quote-string realm)) (return-code *reply*) +http-authorization-required+) - (throw 'handler-done nil)) + (abort-request-handler)) Modified: trunk/thirdparty/hunchentoot/packages.lisp =================================================================== --- trunk/thirdparty/hunchentoot/packages.lisp 2009-02-12 22:33:37 UTC (rev 4249) +++ trunk/thirdparty/hunchentoot/packages.lisp 2009-02-12 23:09:58 UTC (rev 4250) @@ -116,9 +116,11 @@ "+HTTP-UNSUPPORTED-MEDIA-TYPE+" "+HTTP-USE-PROXY+" "+HTTP-VERSION-NOT-SUPPORTED+" + "ABORT-REQUEST-HANDLER" "ACCEPTOR" "ACCEPTOR-ACCESS-LOGGER" "ACCEPTOR-ADDRESS" + "ACCEPTOR-HANDLER-SELECTOR" "ACCEPTOR-INPUT-CHUNKING-P" "ACCEPTOR-MESSAGE-LOGGER" "ACCEPTOR-NAME" @@ -127,7 +129,6 @@ "ACCEPTOR-PORT" "ACCEPTOR-READ-TIMEOUT" "ACCEPTOR-REQUEST-CLASS" - "ACCEPTOR-REQUEST-DISPATCHER" "ACCEPTOR-SSL-P" "ACCEPTOR-SSL-CERTIFICATE-FILE" "ACCEPTOR-SSL-PRIVATEKEY-FILE" @@ -159,7 +160,6 @@ "DELETE-AUX-REQUEST-VALUE" "DELETE-SESSION-VALUE" "DISPATCH-EASY-HANDLERS" - "DISPATCH-REQUEST" "ESCAPE-FOR-HTML" "EXECUTE-ACCEPTOR" "GET-PARAMETER" @@ -168,7 +168,6 @@ "HANDLE-INCOMING-CONNECTION" "HANDLE-IF-MODIFIED-SINCE" "HANDLE-STATIC-FILE" - "HANDLER-DONE" "HEADER-IN" "HEADER-IN*" "HEADER-OUT" Modified: trunk/thirdparty/hunchentoot/request.lisp =================================================================== --- trunk/thirdparty/hunchentoot/request.lisp 2009-02-12 22:33:37 UTC (rev 4249) +++ trunk/thirdparty/hunchentoot/request.lisp 2009-02-12 23:09:58 UTC (rev 4250) @@ -397,7 +397,7 @@ (when (and if-modified-since (equal if-modified-since time-string)) (setf (return-code) +http-not-modified+) - (throw 'handler-done nil)) + (abort-request-handler)) (values))) (defun external-format-from-content-type (content-type) Modified: trunk/thirdparty/hunchentoot/specials.lisp =================================================================== --- trunk/thirdparty/hunchentoot/specials.lisp 2009-02-12 22:33:37 UTC (rev 4249) +++ trunk/thirdparty/hunchentoot/specials.lisp 2009-02-12 23:09:58 UTC (rev 4250) @@ -255,7 +255,7 @@ #+:openmcl "http://openmcl.clozure.com/" "A link to the website of the underlying Lisp implementation.") -(defvar *dispatch-table* (list 'default-dispatcher) +(defvar *dispatch-table* (list 'dispatch-easy-handlers 'default-dispatcher) "A global list of dispatch functions.") (defvar *default-handler* 'default-handler Modified: trunk/thirdparty/hunchentoot/test/test-handlers.lisp =================================================================== --- trunk/thirdparty/hunchentoot/test/test-handlers.lisp 2009-02-12 22:33:37 UTC (rev 4249) +++ trunk/thirdparty/hunchentoot/test/test-handlers.lisp 2009-02-12 23:09:58 UTC (rev 4250) @@ -161,7 +161,7 @@ " cookie test") (:p "You might have to reload this page to see the cookie value.") (info-table (cookie-in "pumpkin") - (mapcar #'car (cookies-in*))))))) + (mapcar 'car (cookies-in*))))))) (defun session-test () (let ((new-foo-value (post-parameter "new-foo-value"))) @@ -200,7 +200,7 @@ :value (or (session-value 'bar) "")))) (info-table (session-cookie-name *acceptor*) (cookie-in (session-cookie-name *acceptor*)) - (mapcar #'car (cookies-in*)) + (mapcar 'car (cookies-in*)) (session-value 'foo) (session-value 'bar)))))) @@ -225,10 +225,10 @@ :name "foo"))) (case method (:get (info-table (query-string*) - (map 'list #'char-code (get-parameter "foo")) + (map 'list 'char-code (get-parameter "foo")) (get-parameter "foo"))) (:post (info-table (raw-post-data) - (map 'list #'char-code (post-parameter "foo")) + (map 'list 'char-code (post-parameter "foo")) (post-parameter "foo")))))))) (defun parameter-test-latin1-get () @@ -262,7 +262,7 @@ :type nil :defaults *tmp-test-directory*))) ;; strip directory info sent by Windows browsers - (when (search "Windows" (user-agent) :test #'char-equal) + (when (search "Windows" (user-agent) :test 'char-equal) (setq file-name (cl-ppcre:regex-replace ".*\\\\" file-name ""))) (rename-file path (ensure-directories-exist new-path)) (push (list new-path file-name content-type) *tmp-test-files*)))))) @@ -328,7 +328,7 @@ (let* ((path (get-parameter "path")) (file-info (and path (find (pathname path) *tmp-test-files* - :key #'first :test #'equal)))) + :key 'first :test 'equal)))) (unless file-info (setf (return-code *reply*) +http-not-found+) @@ -444,7 +444,7 @@ (:input :type "checkbox" :name "team" :value player - :checked (member player team :test #'string=) + :checked (member player team :test 'string=) (esc player)) (:br))))) (:tr @@ -541,7 +541,7 @@ :defaults *this-file*) "text/plain")) (mapcar (lambda (args) - (apply #'create-prefix-dispatcher args)) + (apply 'create-prefix-dispatcher args)) '(("/hunchentoot/test/form-test.html" form-test) ("/hunchentoot/test/forbidden.html" forbidden) ("/hunchentoot/test/info.html" info) @@ -561,4 +561,4 @@ ("/hunchentoot/test/utf8-string.txt" stream-direct-utf-8-string) ("/hunchentoot/test/files/" send-file) ("/hunchentoot/test" menu))) - (list #'default-dispatcher))) + (list 'default-dispatcher)))

1 0

[bknr-cvs] edi changed trunk/thirdparty/hunchentoot/
by BKNR Commits 12 Feb '09

12 Feb '09

Revision: 4249 Author: edi URL: http://bknr.net/trac/changeset/4249 First stab at logging U trunk/thirdparty/hunchentoot/acceptor.lisp U trunk/thirdparty/hunchentoot/headers.lisp U trunk/thirdparty/hunchentoot/log.lisp U trunk/thirdparty/hunchentoot/misc.lisp U trunk/thirdparty/hunchentoot/packages.lisp U trunk/thirdparty/hunchentoot/request.lisp U trunk/thirdparty/hunchentoot/session.lisp U trunk/thirdparty/hunchentoot/specials.lisp U trunk/thirdparty/hunchentoot/test/packages.lisp U trunk/thirdparty/hunchentoot/test/script.lisp Change set too large, please see URL above

1 0

[bknr-cvs] edi changed trunk/thirdparty/documentation-template/doc/clixdoc.xsl
by BKNR Commits 12 Feb '09

12 Feb '09

Revision: 4248 Author: edi URL: http://bknr.net/trac/changeset/4248 Adapt Hans' changes from Hunchentoot U trunk/thirdparty/documentation-template/doc/clixdoc.xsl Modified: trunk/thirdparty/documentation-template/doc/clixdoc.xsl =================================================================== --- trunk/thirdparty/documentation-template/doc/clixdoc.xsl 2009-02-12 21:18:29 UTC (rev 4247) +++ trunk/thirdparty/documentation-template/doc/clixdoc.xsl 2009-02-12 21:21:09 UTC (rev 4248) @@ -39,6 +39,8 @@ omit-xml-declaration="yes" doctype-public="-//W3C//DTD HTML 4.0 Strict//EN" /> + <xsl:key name="index-entries" match="clix:*[@name and (name() != 'clix:chapter') and (name() != 'clix:subchapter')]" use="@name" /> + <xsl:template match="/clix:documentation"> <html xmlns="http://www.w3.org/1999/xhtml"> <head> @@ -50,6 +52,7 @@ pre { padding:5px; background-color:#e0e0e0 } pre.none { padding:5px; background-color:#ffffff } h3, h4, h5 { text-decoration: underline; } + .entry-type { padding-left: 1em; font-size: 60%; font-style: italic } a { text-decoration: none; padding: 1px 2px 1px 2px; } a:visited { text-decoration: none; padding: 1px 2px 1px 2px; } a:hover { text-decoration: none; padding: 1px 1px 1px 1px; border: 1px solid #000000; } @@ -75,25 +78,16 @@ <xsl:template match="clix:function"> - <xsl:choose> - <xsl:when test="@generic = 'true'">[Generic function]</xsl:when> - <xsl:when test="@specialized = 'true'">[Method]</xsl:when> - <xsl:when test="@macro = 'true'">[Macro]</xsl:when> - <xsl:otherwise>[Function]</xsl:otherwise> - </xsl:choose> + <xsl:call-template name="make-anchor"/> + [<xsl:call-template name="nice-entry-type-name"/>] - <a class="none"> - <xsl:attribute name="name"> - <xsl:value-of select="translate(@name, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 'abcdefghijklmnopqrstuvwxyz')"/> - </xsl:attribute> - <xsl:value-of select="@name"/> - <xsl:value-of select="' '"/> - <xsl:apply-templates select="clix:lambda-list"/> - <xsl:if test="clix:returns"> - => - <xsl:value-of select="clix:returns"/> - </xsl:if> - </a> + <xsl:call-template name="render-title"/> + <xsl:value-of select="' '"/> + <xsl:apply-templates select="clix:lambda-list"/> + <xsl:if test="clix:returns"> + => + <xsl:value-of select="clix:returns"/> + </xsl:if> <blockquote> <xsl:apply-templates select="clix:description"/> </blockquote> @@ -102,24 +96,16 @@ <xsl:template match="clix:reader"> - <xsl:choose> - <xsl:when test="@generic = 'true'">[Generic reader]</xsl:when> - <xsl:when test="@specialized = 'true'">[Specialized reader]</xsl:when> - <xsl:otherwise>[Reader]</xsl:otherwise> - </xsl:choose> + <xsl:call-template name="make-anchor"/> + [<xsl:call-template name="nice-entry-type-name"/>] - <a class="none"> - <xsl:attribute name="name"> - <xsl:value-of select="translate(@name, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 'abcdefghijklmnopqrstuvwxyz')"/> - </xsl:attribute> - <xsl:value-of select="@name"/> - <xsl:value-of select="' '"/> - <xsl:apply-templates select="clix:lambda-list"/> - <xsl:if test="clix:returns"> - => - <xsl:value-of select="clix:returns"/> - </xsl:if> - </a> + <xsl:call-template name="render-title"/> + <xsl:value-of select="' '"/> + <xsl:apply-templates select="clix:lambda-list"/> + <xsl:if test="clix:returns"> + => + <xsl:value-of select="clix:returns"/> + </xsl:if> <blockquote> <xsl:apply-templates select="clix:description"/> </blockquote> @@ -128,24 +114,16 @@ <xsl:template match="clix:writer"> - <xsl:choose> - <xsl:when test="@generic = 'true'">[Generic writer]</xsl:when> - <xsl:when test="@specialized = 'true'">[Specialized writer]</xsl:when> - <xsl:otherwise>[Writer]</xsl:otherwise> - </xsl:choose> + <xsl:call-template name="make-anchor"/> + [<xsl:call-template name="nice-entry-type-name"/>] - <a class="none"> - <xsl:attribute name="name"> - <xsl:value-of select="translate(@name, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 'abcdefghijklmnopqrstuvwxyz')"/> - </xsl:attribute> - <tt>(setf (</tt><xsl:value-of select="@name"/> - <xsl:value-of select="' '"/> - <xsl:apply-templates select="clix:lambda-list"/><tt>) new-value)</tt> - <xsl:if test="clix:returns"> - => - <xsl:value-of select="clix:returns"/> - </xsl:if> - </a> + <tt>(setf (</tt><xsl:value-of select="@name"/> + <xsl:value-of select="' '"/> + <xsl:apply-templates select="clix:lambda-list"/><tt>) new-value)</tt> + <xsl:if test="clix:returns"> + => + <xsl:value-of select="clix:returns"/> + </xsl:if> <blockquote> <xsl:apply-templates select="clix:description"/> </blockquote> @@ -154,112 +132,38 @@ <xsl:template match="clix:accessor"> - <xsl:choose> - <xsl:when test="@generic = 'true'">[Generic accessor]</xsl:when> - <xsl:when test="@specialized = 'true'">[Specialized accessor]</xsl:when> - <xsl:otherwise>[Accessor]</xsl:otherwise> - </xsl:choose> + <xsl:call-template name="make-anchor"/> + [<xsl:call-template name="nice-entry-type-name"/>] - <a class="none"> - <xsl:attribute name="name"> - <xsl:value-of select="translate(@name, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 'abcdefghijklmnopqrstuvwxyz')"/> - </xsl:attribute> - <xsl:value-of select="@name"/> - <xsl:value-of select="' '"/> - <xsl:apply-templates select="clix:lambda-list"/> - => - <xsl:value-of select="clix:returns"/> - - <tt>(setf (</tt><xsl:value-of select="@name"/> - <xsl:value-of select="' '"/> - <xsl:apply-templates select="clix:lambda-list"/><tt>) new-value)</tt> - </a> + <xsl:call-template name="render-title"/> + <xsl:value-of select="' '"/> + <xsl:apply-templates select="clix:lambda-list"/> + => + <xsl:value-of select="clix:returns"/> + + <tt>(setf (</tt><xsl:value-of select="@name"/> + <xsl:value-of select="' '"/> + <xsl:apply-templates select="clix:lambda-list"/><tt>) new-value)</tt> <blockquote> <xsl:apply-templates select="clix:description"/> </blockquote> </xsl:template> - <xsl:template match="clix:special-variable"> + <xsl:template match="clix:special-variable | clix:class | clix:condition | clix:symbol | clix:constant"> - [Special variable] - <a class="none"> - <xsl:attribute name="name"> - <xsl:value-of select="translate(@name, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 'abcdefghijklmnopqrstuvwxyz')"/> - </xsl:attribute> - <xsl:value-of select="@name"/> - </a> + <xsl:call-template name="make-anchor"/> + [<xsl:call-template name="nice-entry-type-name"/>] + + <xsl:call-template name="render-title"/> <blockquote> <xsl:apply-templates select="clix:description"/> </blockquote> </xsl:template> - <xsl:template match="clix:class"> - - [Standard class] - <a class="none"> - <xsl:attribute name="name"> - <xsl:value-of select="translate(@name, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 'abcdefghijklmnopqrstuvwxyz')"/> - </xsl:attribute> - <xsl:value-of select="@name"/> - </a> - <blockquote> - <xsl:apply-templates select="clix:description"/> - </blockquote> - - </xsl:template> - - <xsl:template match="clix:condition"> - - [Condition type] - <a class="none"> - <xsl:attribute name="name"> - <xsl:value-of select="translate(@name, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 'abcdefghijklmnopqrstuvwxyz')"/> - </xsl:attribute> - <xsl:value-of select="@name"/> - </a> - <blockquote> - <xsl:apply-templates select="clix:description"/> - </blockquote> - - </xsl:template> - - <xsl:template match="clix:symbol"> - - [Symbol] - <a class="none"> - <xsl:attribute name="name"> - <xsl:value-of select="translate(@name, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 'abcdefghijklmnopqrstuvwxyz')"/> - </xsl:attribute> - <xsl:value-of select="@name"/> - </a> - <blockquote> - <xsl:apply-templates select="clix:description"/> - </blockquote> - - </xsl:template> - - <xsl:template match="clix:constant"> - - [Constant] - <a class="none"> - <xsl:attribute name="name"> - <xsl:value-of select="translate(@name, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 'abcdefghijklmnopqrstuvwxyz')"/> - </xsl:attribute> - <xsl:value-of select="@name"/> - </a> - <blockquote> - <xsl:apply-templates select="clix:description"/> - </blockquote> - - </xsl:template> - <xsl:template match="clix:listed-constant"> - <a class="none"> - <xsl:attribute name="name"><xsl:value-of select="@name"/></xsl:attribute> - <xsl:value-of select="@name"/> - </a> + <xsl:call-template name="render-title"/> </xsl:template> @@ -289,19 +193,6 @@ <code><xsl:value-of select="text()"/></code> </xsl:template> - <xsl:template name="internal-reference"> -  - <xsl:param name="name"/> - <code> - <a> - <xsl:attribute name="href"> - #<xsl:value-of select="translate($name, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 'abcdefghijklmnopqrstuvwxyz')"/> - </xsl:attribute> - <xsl:value-of select="$name"/> - </a> - </code> - </xsl:template> - <xsl:template match="clix:ref"> <xsl:call-template name="internal-reference"> <xsl:with-param name="name"><xsl:value-of select="."/></xsl:with-param> @@ -355,12 +246,37 @@ <xsl:template match="clix:index"> <ul> - <xsl:for-each select="(//clix:function | //clix:reader | //clix:writer | //clix:accessor | //clix:class | //clix:condition | //clix:constant | //clix:listed-constant | //clix:special-variable | //clix:symbol)"> + <xsl:for-each select="//clix:*[generate-id(.) = generate-id(key('index-entries', @name)[1])]"> <xsl:sort select="@name"/> <li> - <xsl:call-template name="internal-reference"> - <xsl:with-param name="name"><xsl:value-of select="@name"/></xsl:with-param> - </xsl:call-template> + <xsl:choose> + <xsl:when test="count(key('index-entries', @name)) = 1"> + <xsl:call-template name="internal-reference"> + <xsl:with-param name="name"><xsl:value-of select="@name"/></xsl:with-param> + </xsl:call-template> + <xsl:call-template name="nice-entry-type-name"/> + </xsl:when> + <xsl:otherwise> + <a> + <xsl:attribute name="name"> + <xsl:value-of select="@name"/> + </xsl:attribute> + </a> + <xsl:value-of select="@name"/> + <ul> + <xsl:for-each select="key('index-entries', @name)"> + <xsl:sort select="name()"/> + <li> + <xsl:call-template name="internal-reference"> + <xsl:with-param name="name"><xsl:call-template name="make-anchor-name"/></xsl:with-param> + <xsl:with-param name="title"><xsl:value-of select="@name"/></xsl:with-param> + </xsl:call-template> + <xsl:call-template name="nice-entry-type-name"/> + </li> + </xsl:for-each> + </ul> + </xsl:otherwise> + </xsl:choose> </li> </xsl:for-each> </ul> @@ -373,4 +289,91 @@ </xsl:copy> </xsl:template> + <xsl:template name="internal-reference"> +  + <xsl:param name="name"/> + <xsl:param name="title"/> + <code> + <a> + <xsl:attribute name="href"> + #<xsl:value-of select="translate($name, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 'abcdefghijklmnopqrstuvwxyz')"/> + </xsl:attribute> + <xsl:choose> + <xsl:when test="$title != ''"> + <xsl:value-of select="$title"/> + </xsl:when> + <xsl:otherwise> + <xsl:value-of select="$name"/> + </xsl:otherwise> + </xsl:choose> + </a> + </code> + </xsl:template> + + <xsl:template name="make-anchor-name"> + <xsl:choose> + <xsl:when test="count(key('index-entries', @name)) = 1"> + <xsl:value-of select="translate(@name, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 'abcdefghijklmnopqrstuvwxyz')"/> + </xsl:when> + <xsl:otherwise> + <xsl:value-of select="translate(@name, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 'abcdefghijklmnopqrstuvwxyz')"/>-<xsl:value-of select="substring(name(), 6)"/> + </xsl:otherwise> + </xsl:choose> + </xsl:template> + + <xsl:template name="make-anchor"> + <a class="none"> + <xsl:attribute name="name"> + <xsl:call-template name="make-anchor-name"/> + </xsl:attribute> + </a> + </xsl:template> + + <xsl:template name="render-title"> + <xsl:value-of select="@name"/> + </xsl:template> + + <xsl:template name="nice-entry-type-name"> + <xsl:choose> + <xsl:when test="name() = 'clix:function'"> + <xsl:choose> + <xsl:when test="@generic = 'true'">Generic function</xsl:when> + <xsl:when test="@specialized = 'true'">Method</xsl:when> + <xsl:when test="@macro = 'true'">Macro</xsl:when> + <xsl:otherwise>Function</xsl:otherwise> + </xsl:choose> + </xsl:when> + <xsl:when test="name() = 'clix:reader'"> + <xsl:choose> + <xsl:when test="@generic = 'true'">Generic reader</xsl:when> + <xsl:when test="@specialized = 'true'">Specialized reader</xsl:when> + <xsl:otherwise>Reader</xsl:otherwise> + </xsl:choose> + </xsl:when> + <xsl:when test="name() = 'clix:writer'"> + <xsl:choose> + <xsl:when test="@generic = 'true'">Generic writer</xsl:when> + <xsl:when test="@specialized = 'true'">Specialized writer</xsl:when> + <xsl:otherwise>Writer</xsl:otherwise> + </xsl:choose> + </xsl:when> + <xsl:when test="name() = 'clix:accessor'"> + <xsl:choose> + <xsl:when test="@generic = 'true'">Generic accessor</xsl:when> + <xsl:when test="@specialized = 'true'">Specialized accessor</xsl:when> + <xsl:otherwise>Accessor</xsl:otherwise> + </xsl:choose> + </xsl:when> + <xsl:when test="name() = 'clix:special-variable'">Special variable</xsl:when> + <xsl:when test="name() = 'clix:class'">Standard class</xsl:when> + <xsl:when test="name() = 'clix:condition'">Condition type</xsl:when> + <xsl:when test="name() = 'clix:symbol'">Symbol</xsl:when> + <xsl:when test="name() = 'clix:constant'">Constant</xsl:when> + <xsl:when test="name() = 'clix:listed-constant'">Constant</xsl:when> + <xsl:otherwise> + <xsl:value-of select="name()" /> + </xsl:otherwise> + </xsl:choose> + </xsl:template> + </xsl:stylesheet>

1 0

[bknr-cvs] edi changed trunk/thirdparty/hunchentoot/
by BKNR Commits 12 Feb '09

12 Feb '09

Revision: 4247 Author: edi URL: http://bknr.net/trac/changeset/4247 Checkpoint U trunk/thirdparty/hunchentoot/acceptor.lisp U trunk/thirdparty/hunchentoot/hunchentoot.asd U trunk/thirdparty/hunchentoot/log.lisp U trunk/thirdparty/hunchentoot/packages.lisp U trunk/thirdparty/hunchentoot/ssl.lisp Modified: trunk/thirdparty/hunchentoot/acceptor.lisp =================================================================== --- trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-12 20:54:43 UTC (rev 4246) +++ trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-12 21:18:29 UTC (rev 4247) @@ -268,6 +268,7 @@ (multiple-value-bind (remote-addr remote-port) (get-peer-address-and-port socket) (process-request (make-instance (acceptor-request-class *acceptor*) + :acceptor *acceptor* :remote-addr remote-addr :remote-port remote-port :headers-in headers-in @@ -319,7 +320,10 @@ (when error (setf (return-code *reply*) +http-internal-server-error+)) - (start-output :content (cond (error + (start-output :content (cond ((and error *show-lisp-errors-p*) + (format nil "<pre>~A</pre>" + (escape-for-html (format nil "~A" error)))) + (error "An error has occured.") (t body)))) t) Modified: trunk/thirdparty/hunchentoot/hunchentoot.asd =================================================================== --- trunk/thirdparty/hunchentoot/hunchentoot.asd 2009-02-12 20:54:43 UTC (rev 4246) +++ trunk/thirdparty/hunchentoot/hunchentoot.asd 2009-02-12 21:18:29 UTC (rev 4247) @@ -61,10 +61,8 @@ (:file "util") (:file "url-rewrite"))) (:file "packages") - #+:lispworks - (:file "lispworks") - #-:lispworks - (:file "compat") + #+:lispworks (:file "lispworks") + #-:lispworks (:file "compat") (:file "specials") (:file "conditions") (:file "mime-types") @@ -80,5 +78,4 @@ (:file "set-timeouts") (:file "connection-dispatcher") (:file "acceptor") - #-:hunchentoot-no-ssl - (:file "ssl"))) + #-:hunchentoot-no-ssl (:file "ssl"))) Modified: trunk/thirdparty/hunchentoot/log.lisp =================================================================== --- trunk/thirdparty/hunchentoot/log.lisp 2009-02-12 20:54:43 UTC (rev 4246) +++ trunk/thirdparty/hunchentoot/log.lisp 2009-02-12 21:18:29 UTC (rev 4247) @@ -100,7 +100,7 @@ (setf (log-file-pathname ,special-variable) pathname))))) (define-log-file log-file *log-file* *log-pathname* - "file to use to log general messages.") + "File to use to log general messages.") (defmethod log-message (log-level format &rest args) "Sends a formatted message to the file denoted by *LOG-FILE*. @@ -113,7 +113,7 @@ (defun log-message* (log-level format &rest args) "Internal function accepting the same arguments as LOG-MESSAGE and -using the message logger of *SERVER* \(if there is one)." +using the message logger of *ACCEPTOR* \(if there is one)." (when-let (message-logger (acceptor-message-logger *acceptor*)) (apply message-logger log-level format args))) Modified: trunk/thirdparty/hunchentoot/packages.lisp =================================================================== --- trunk/thirdparty/hunchentoot/packages.lisp 2009-02-12 20:54:43 UTC (rev 4246) +++ trunk/thirdparty/hunchentoot/packages.lisp 2009-02-12 21:18:29 UTC (rev 4247) @@ -127,6 +127,9 @@ "ACCEPTOR-REQUEST-CLASS" "ACCEPTOR-REQUEST-DISPATCHER" "ACCEPTOR-SSL-P" + "ACCEPTOR-SSL-CERTIFICATE-FILE" + "ACCEPTOR-SSL-PRIVATEKEY-FILE" + "ACCEPTOR-SSL-PRIVATEKEY-PASSWORD" "ACCEPTOR-WRITE-TIMEOUT" "ACCESS-LOG-FILE" "AUTHORIZATION" @@ -231,6 +234,7 @@ "SET-COOKIE" "SET-COOKIE*" "SHUTDOWN" + "SSL-ACCEPTOR" "SSL-P" "START" "START-LISTENING" Modified: trunk/thirdparty/hunchentoot/ssl.lisp =================================================================== --- trunk/thirdparty/hunchentoot/ssl.lisp 2009-02-12 20:54:43 UTC (rev 4246) +++ trunk/thirdparty/hunchentoot/ssl.lisp 2009-02-12 21:18:29 UTC (rev 4247) @@ -44,21 +44,38 @@ :reader acceptor-ssl-privatekey-password :documentation "The password for the private key file or NIL.")) - (:default-initargs :port 443 :output-chunking-p nil) + (:default-initargs + :port 443 + :input-chunking-p nil + :output-chunking-p nil) (:documentation "This class defines additional slots required to -serve requests by SSL")) +serve requests via SSL.")) -(defmethod initialize-instance :around ((acceptor ssl-acceptor) - &rest args - &key ssl-certificate-file ssl-privatekey-file - &allow-other-keys) - (apply #'call-next-method acceptor - :ssl-certificate-file (namestring ssl-certificate-file) - :ssl-privatekey-file (namestring (or ssl-privatekey-file - #+:lispworks - ssl-certificate-file)) - args)) +;; general implementation +(defmethod acceptor-ssl-p ((acceptor ssl-acceptor)) + t) + +;; usocket implementation + +#-:lispworks +(defmethod initialize-connection-stream ((acceptor ssl-acceptor) stream) + ;; attach SSL to the stream if necessary + (call-next-method acceptor + (cl+ssl:make-ssl-server-stream stream + :certificate (acceptor-ssl-certificate-file acceptor) + :key (acceptor-ssl-privatekey-file acceptor)))) + +;; LispWorks implementation + +#+:lispworks +(defmethod initialize-instance :after ((acceptor ssl-acceptor) &rest initargs) + (declare (ignore initargs)) + ;; LispWorks can read both from the same file, so we can default one + (unless (slot-boundp acceptor 'ssl-privatekey-file) + (setf (slot-value acceptor 'ssl-privatekey-file) + (acceptor-ssl-certificate-file acceptor)))) + #+lispworks (defun make-ssl-server-stream (socket-stream &key certificate-file privatekey-file privatekey-password) "Given the acceptor socket stream SOCKET-STREAM attaches SSL to the @@ -80,19 +97,11 @@ :ctx-configure-callback #'ctx-configure-callback) socket-stream)) - -(defmethod acceptor-ssl-p ((acceptor ssl-acceptor)) - t) - +#+:lispworks (defmethod initialize-connection-stream ((acceptor ssl-acceptor) stream) ;; attach SSL to the stream if necessary (call-next-method acceptor - #+:lispworks (make-ssl-server-stream stream :certificate-file (acceptor-ssl-certificate-file acceptor) :privatekey-file (acceptor-ssl-privatekey-file acceptor) - :privatekey-password (acceptor-ssl-privatekey-password acceptor)) - #-:lispworks - (cl+ssl:make-ssl-server-stream stream - :certificate (acceptor-ssl-certificate-file acceptor) - :key (acceptor-ssl-privatekey-file acceptor)))) \ No newline at end of file + :privatekey-password (acceptor-ssl-privatekey-password acceptor)))) \ No newline at end of file

1 0

[bknr-cvs] edi changed trunk/thirdparty/hunchentoot/test/test-handlers.lisp
by BKNR Commits 12 Feb '09

12 Feb '09

Revision: 4246 Author: edi URL: http://bknr.net/trac/changeset/4246 Fix wrong link due to renaming U trunk/thirdparty/hunchentoot/test/test-handlers.lisp Modified: trunk/thirdparty/hunchentoot/test/test-handlers.lisp =================================================================== --- trunk/thirdparty/hunchentoot/test/test-handlers.lisp 2009-02-12 17:00:04 UTC (rev 4245) +++ trunk/thirdparty/hunchentoot/test/test-handlers.lisp 2009-02-12 20:54:43 UTC (rev 4246) @@ -488,7 +488,7 @@ (:tr (:td (:a :href "/hunchentoot/test/authorization.html" "Authorization") " (user 'nanook', password 'igloo')")) - (:tr (:td (:a :href "/hunchentoot/code/test.lisp" + (:tr (:td (:a :href "/hunchentoot/code/test-handlers.lisp" "The source code of this test"))) (:tr (:td (:a :href "/hunchentoot/test/image.jpg" "Binary data, delivered from file")

1 0

[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/
by BKNR Commits 12 Feb '09

12 Feb '09

Revision: 4245 Author: hans URL: http://bknr.net/trac/changeset/4245 Only try to set timeout if not NIL. Only try to rewrite when a session has been set up. U trunk/thirdparty/hunchentoot/headers.lisp U trunk/thirdparty/hunchentoot/set-timeouts.lisp Modified: trunk/thirdparty/hunchentoot/headers.lisp =================================================================== --- trunk/thirdparty/hunchentoot/headers.lisp 2009-02-12 09:04:52 UTC (rev 4244) +++ trunk/thirdparty/hunchentoot/headers.lisp 2009-02-12 17:00:04 UTC (rev 4245) @@ -177,6 +177,7 @@ (write-sequence +crlf+ *hunchentoot-stream*) (maybe-write-to-header-stream first-line)) (when (and (stringp content) + (session *request*) (not content-modified-p) (starts-with-one-of-p (or (content-type) "") *content-types-for-url-rewrite*)) Modified: trunk/thirdparty/hunchentoot/set-timeouts.lisp =================================================================== --- trunk/thirdparty/hunchentoot/set-timeouts.lisp 2009-02-12 09:04:52 UTC (rev 4244) +++ trunk/thirdparty/hunchentoot/set-timeouts.lisp 2009-02-12 17:00:04 UTC (rev 4245) @@ -61,8 +61,9 @@ (setf (ccl:stream-output-timeout (usocket:socket usocket)) write-timeout)) #+:sbcl - (setf (sb-impl::fd-stream-timeout (usocket:socket-stream usocket)) - (coerce read-timeout 'single-float)) + (when read-timeout + (setf (sb-impl::fd-stream-timeout (usocket:socket-stream usocket)) + (coerce read-timeout 'single-float))) #+:cmu (setf (lisp::fd-stream-timeout (usocket:socket-stream usocket)) (coerce read-timeout 'integer))

1 0

[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/
by BKNR Commits 12 Feb '09

12 Feb '09

Revision: 4244 Author: hans URL: http://bknr.net/trac/changeset/4244 Compilation fixes for non-Lispworks. Compiles, but does not run yet. A trunk/thirdparty/hunchentoot/compat.lisp U trunk/thirdparty/hunchentoot/hunchentoot.asd U trunk/thirdparty/hunchentoot/session.lisp U trunk/thirdparty/hunchentoot/util.lisp Added: trunk/thirdparty/hunchentoot/compat.lisp =================================================================== --- trunk/thirdparty/hunchentoot/compat.lisp (rev 0) +++ trunk/thirdparty/hunchentoot/compat.lisp 2009-02-12 09:04:52 UTC (rev 4244) @@ -0,0 +1,114 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/util.lisp,v 1.35 2008/04/08 14:39:18 edi Exp $ + +;;; Copyright (c) 2004-2009, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :hunchentoot) + +(defmacro when-let ((var form) &body body) + "Evaluates FORM and binds VAR to the result, then executes BODY +if VAR has a true value." + `(let ((,var ,form)) + (when ,var ,@body))) + +(defmacro with-unique-names ((&rest bindings) &body body) + "Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form* + +Executes a series of forms with each VAR bound to a fresh, +uninterned symbol. The uninterned symbol is as if returned by a call +to GENSYM with the string denoted by X - or, if X is not supplied, the +string denoted by VAR - as argument. + +The variable bindings created are lexical unless special declarations +are specified. The scopes of the name bindings and declarations do not +include the Xs. + +The forms are evaluated in order, and the values of all but the last +are discarded \(that is, the body is an implicit PROGN)." + ;; reference implementation posted to comp.lang.lisp as + ;; <cy3bshuf30f.fsf(a)ljosa.com> by Vebjorn Ljosa - see also + ;; <http://www.cliki.net/Common%20Lisp%20Utilities> + `(let ,(mapcar #'(lambda (binding) + (check-type binding (or cons symbol)) + (if (consp binding) + (destructuring-bind (var x) binding + (check-type var symbol) + `(,var (gensym ,(etypecase x + (symbol (symbol-name x)) + (character (string x)) + (string x))))) + `(,binding (gensym ,(symbol-name binding))))) + bindings) + ,@body)) + +(defmacro with-rebinding (bindings &body body) + "Syntax: WITH-REBINDING ( { var | (var prefix) }* ) form* + +Evaluates a series of forms in the lexical environment that is +formed by adding the binding of each VAR to a fresh, uninterned +symbol, and the binding of that fresh, uninterned symbol to VAR's +original value, i.e., its value in the current lexical environment. + +The uninterned symbol is created as if by a call to GENSYM with the +string denoted by PREFIX - or, if PREFIX is not supplied, the string +denoted by VAR - as argument. + +The forms are evaluated in order, and the values of all but the last +are discarded \(that is, the body is an implicit PROGN)." + ;; reference implementation posted to comp.lang.lisp as + ;; <cy3wv0fya0p.fsf(a)ljosa.com> by Vebjorn Ljosa - see also + ;; <http://www.cliki.net/Common%20Lisp%20Utilities> + (loop for binding in bindings + for var = (if (consp binding) (car binding) binding) + for name = (gensym) + collect `(,name ,var) into renames + collect ``(,,var ,,name) into temps + finally (return `(let ,renames + (with-unique-names ,bindings + `(let (,,@temps) + ,,@body)))))) + +(defun get-peer-address-and-port (socket) + "Returns the peer address and port of the socket SOCKET as two +values. The address is returned as a string in dotted IP address +notation." + (values (usocket:vector-quad-to-dotted-quad (usocket:get-peer-address socket)) + (usocket:get-peer-port socket))) + +(defun make-socket-stream (socket server) + "Returns a stream for the socket SOCKET. The SERVER argument is +ignored." + (declare (ignore server)) + (usocket:socket-stream socket)) + +(defun make-lock (name) + "Simple wrapper to allow LispWorks and Bordeaux Threads to coexist." + (bt:make-lock name)) + +(defmacro with-lock-held ((lock) &body body) + "Simple wrapper to allow LispWorks and Bordeaux Threads to coexist." + `(bt:with-lock-held (,lock) ,@body)) \ No newline at end of file Modified: trunk/thirdparty/hunchentoot/hunchentoot.asd =================================================================== --- trunk/thirdparty/hunchentoot/hunchentoot.asd 2009-02-11 23:54:40 UTC (rev 4243) +++ trunk/thirdparty/hunchentoot/hunchentoot.asd 2009-02-12 09:04:52 UTC (rev 4244) @@ -63,6 +63,8 @@ (:file "packages") #+:lispworks (:file "lispworks") + #-:lispworks + (:file "compat") (:file "specials") (:file "conditions") (:file "mime-types") Modified: trunk/thirdparty/hunchentoot/session.lisp =================================================================== --- trunk/thirdparty/hunchentoot/session.lisp 2009-02-11 23:54:40 UTC (rev 4243) +++ trunk/thirdparty/hunchentoot/session.lisp 2009-02-12 09:04:52 UTC (rev 4244) @@ -29,7 +29,7 @@ (in-package :hunchentoot) -(defgeneric session-db-lock (acceptor &key (whole-db-p t)) +(defgeneric session-db-lock (acceptor &key whole-db-p) (:documentation "A function which returns a lock that will be used to prevent concurrent access to sessions. The first argument will be the acceptor that handles the current request, the second argument is Modified: trunk/thirdparty/hunchentoot/util.lisp =================================================================== --- trunk/thirdparty/hunchentoot/util.lisp 2009-02-11 23:54:40 UTC (rev 4243) +++ trunk/thirdparty/hunchentoot/util.lisp 2009-02-12 09:04:52 UTC (rev 4244) @@ -29,72 +29,7 @@ (in-package :hunchentoot) -#-:lispworks -(defmacro when-let ((var form) &body body) - "Evaluates FORM and binds VAR to the result, then executes BODY -if VAR has a true value." - `(let ((,var ,form)) - (when ,var ,@body))) -#-:lispworks -(defmacro with-unique-names ((&rest bindings) &body body) - "Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form* - -Executes a series of forms with each VAR bound to a fresh, -uninterned symbol. The uninterned symbol is as if returned by a call -to GENSYM with the string denoted by X - or, if X is not supplied, the -string denoted by VAR - as argument. - -The variable bindings created are lexical unless special declarations -are specified. The scopes of the name bindings and declarations do not -include the Xs. - -The forms are evaluated in order, and the values of all but the last -are discarded \(that is, the body is an implicit PROGN)." - ;; reference implementation posted to comp.lang.lisp as - ;; <cy3bshuf30f.fsf(a)ljosa.com> by Vebjorn Ljosa - see also - ;; <http://www.cliki.net/Common%20Lisp%20Utilities> - `(let ,(mapcar #'(lambda (binding) - (check-type binding (or cons symbol)) - (if (consp binding) - (destructuring-bind (var x) binding - (check-type var symbol) - `(,var (gensym ,(etypecase x - (symbol (symbol-name x)) - (character (string x)) - (string x))))) - `(,binding (gensym ,(symbol-name binding))))) - bindings) - ,@body)) - -#-:lispworks -(defmacro with-rebinding (bindings &body body) - "Syntax: WITH-REBINDING ( { var | (var prefix) }* ) form* - -Evaluates a series of forms in the lexical environment that is -formed by adding the binding of each VAR to a fresh, uninterned -symbol, and the binding of that fresh, uninterned symbol to VAR's -original value, i.e., its value in the current lexical environment. - -The uninterned symbol is created as if by a call to GENSYM with the -string denoted by PREFIX - or, if PREFIX is not supplied, the string -denoted by VAR - as argument. - -The forms are evaluated in order, and the values of all but the last -are discarded \(that is, the body is an implicit PROGN)." - ;; reference implementation posted to comp.lang.lisp as - ;; <cy3wv0fya0p.fsf(a)ljosa.com> by Vebjorn Ljosa - see also - ;; <http://www.cliki.net/Common%20Lisp%20Utilities> - (loop for binding in bindings - for var = (if (consp binding) (car binding) binding) - for name = (gensym) - collect `(,name ,var) into renames - collect ``(,,var ,,name) into temps - finally (return `(let ,renames - (with-unique-names ,bindings - `(let (,,@temps) - ,,@body)))))) - (defun starts-with-p (seq subseq &key (test 'eql)) "Tests whether the sequence SEQ starts with the sequence SUBSEQ. Individual elements are compared with TEST." @@ -385,27 +320,3 @@ "Whether the current connection to the client is secure." (acceptor-ssl-p acceptor)) -#-:lispworks -(defun get-peer-address-and-port (socket) - "Returns the peer address and port of the socket SOCKET as two -values. The address is returned as a string in dotted IP address -notation." - (values (usocket:vector-quad-to-dotted-quad (usocket:get-peer-address socket)) - (usocket:get-peer-port socket))) - -#-:lispworks -(defun make-socket-stream (socket server) - "Returns a stream for the socket SOCKET. The SERVER argument is -ignored." - (declare (ignore server)) - (usocket:socket-stream socket)) - -#-:lispworks -(defun make-lock (name) - "Simple wrapper to allow LispWorks and Bordeaux Threads to coexist." - (bt:make-lock name)) - -#-:lispworks -(defmacro with-lock-held ((lock) &body body) - "Simple wrapper to allow LispWorks and Bordeaux Threads to coexist." - `(bt:with-lock-held (,lock) ,@body)) \ No newline at end of file

1 0

← Newer
1
...
5
6
7
8
9
10
11
...
14
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

bknr-cvs February 2009