- bknr-cvs@common-lisp.net - mailman3.common-lisp.net

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

10 Feb '09

Revision: 4225 Author: edi URL: http://bknr.net/trac/changeset/4225 Rename file A trunk/thirdparty/hunchentoot/acceptor.lisp D trunk/thirdparty/hunchentoot/server.lisp Change set too large, please see URL above

1 0

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

10 Feb '09

Revision: 4224 Author: edi URL: http://bknr.net/trac/changeset/4224 Checkpoint, not in a working state U trunk/thirdparty/hunchentoot/connection-dispatcher.lisp U trunk/thirdparty/hunchentoot/hunchentoot.asd U trunk/thirdparty/hunchentoot/server.lisp U trunk/thirdparty/hunchentoot/specials.lisp Change set too large, please see URL above

1 0

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

10 Feb '09

Revision: 4223 Author: edi URL: http://bknr.net/trac/changeset/4223 Remove in test as well U trunk/thirdparty/hunchentoot/test/test.lisp Modified: trunk/thirdparty/hunchentoot/test/test.lisp =================================================================== --- trunk/thirdparty/hunchentoot/test/test.lisp 2009-02-10 10:45:45 UTC (rev 4222) +++ trunk/thirdparty/hunchentoot/test/test.lisp 2009-02-10 10:49:33 UTC (rev 4223) @@ -513,14 +513,10 @@ "Forbidden \(403) page"))) (:tr (:td (:a :href "/hunchentoot/test/oops.html" "Error handling") - " \(output depends on settings like " + " \(output depends on " (:a :href "http://weitz.de/hunchentoot/#*show-lisp-errors-p*" (:code "*SHOW-LISP-ERRORS-P*")) - (fmt " \(currently ~S) and " *show-lisp-errors-p*) - (:a :href "http://weitz.de/hunchentoot/#*show-lisp-backtraces-p*" - (:code "*SHOW-LISP-BACKTRACES-P*")) - (fmt " \(currently ~S)" *show-lisp-backtraces-p*) - ")")) + (fmt " \(currently ~S))" *show-lisp-errors-p*))) (:tr (:td (:a :href "/hunchentoot/foo" "URI handled by") " "

1 0

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

10 Feb '09

Revision: 4222 Author: edi URL: http://bknr.net/trac/changeset/4222 Get rid of backtraces D trunk/thirdparty/hunchentoot/get-backtrace.lisp U trunk/thirdparty/hunchentoot/hunchentoot.asd U trunk/thirdparty/hunchentoot/packages.lisp U trunk/thirdparty/hunchentoot/server.lisp U trunk/thirdparty/hunchentoot/specials.lisp Deleted: trunk/thirdparty/hunchentoot/get-backtrace.lisp =================================================================== --- trunk/thirdparty/hunchentoot/get-backtrace.lisp 2009-02-10 10:32:09 UTC (rev 4221) +++ trunk/thirdparty/hunchentoot/get-backtrace.lisp 2009-02-10 10:45:45 UTC (rev 4222) @@ -1,125 +0,0 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/hunchentoot/port-cmu.lisp,v 1.12 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) - -#+cmu -(defun get-backtrace (error) - "This is the function that is used internally by Hunchentoot to -show or log backtraces. It accepts a condition object ERROR and -returns a string with the corresponding backtrace." - (declare (ignore error)) - (with-output-to-string (s) - (let ((debug:*debug-print-level* nil) - (debug:*debug-print-length* nil)) - (debug:backtrace most-positive-fixnum s)))) - -#+allegro -(defun get-backtrace (error) - "This is the function that is used internally by Hunchentoot to -show or log backtraces. It accepts a condition object ERROR and -returns a string with the corresponding backtrace." - (with-output-to-string (s) - (with-standard-io-syntax - (let ((*print-readably* nil) - (*print-miser-width* 40) - (*print-pretty* t) - (tpl:*zoom-print-circle* t) - (tpl:*zoom-print-level* nil) - (tpl:*zoom-print-length* nil)) - (ignore-errors - (format *terminal-io* "~ -~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%" - error)) - (ignore-errors - (let ((*terminal-io* s) - (*standard-output* s)) - (tpl:do-command "zoom" - :from-read-eval-print-loop nil - :count t - :all t))))))) - -#+openmcl -(defun get-backtrace (error) - "This is the function that is used internally by Hunchentoot to -show or log backtraces. It accepts a condition object ERROR and -returns a string with the corresponding backtrace." - (with-output-to-string (s) - (let ((*debug-io* s)) - (format *terminal-io* "~ -~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%" - error) - (ccl:print-call-history :detailed-p nil)))) - -#+clisp -(defun get-backtrace (error) - "This is the function that is used internally by Hunchentoot to -show or log backtraces." - (declare (ignore error)) - (with-output-to-string (stream) - (system::print-backtrace :out stream))) - -#+lispworks -(defun get-backtrace (error) - "This is the function that is used internally by Hunchentoot to -show or log backtraces. It accepts a condition object ERROR and -returns a string with the corresponding backtrace." - (declare (ignore error)) - (with-output-to-string (s) - (let ((dbg::*debugger-stack* (dbg::grab-stack nil :how-many most-positive-fixnum)) - (*debug-io* s) - (dbg:*debug-print-level* nil) - (dbg:*debug-print-length* nil)) - (dbg:bug-backtrace nil)))) - - -;; determine how we're going to access the backtrace in the next -;; function -#+sbcl -(eval-when (:compile-toplevel :load-toplevel :execute) - (when (find-symbol "*DEBUG-PRINT-VARIABLE-ALIST*" :sb-debug) - (pushnew :hunchentoot-sbcl-debug-print-variable-alist *features*))) - -#+sbcl -(defun get-backtrace (error) - "This is the function that is used internally by Hunchentoot to -show or log backtraces. It accepts a condition object ERROR and -returns a string with the corresponding backtrace." - (declare (ignore error)) - (with-output-to-string (s) - #+:hunchentoot-sbcl-debug-print-variable-alist - (let ((sb-debug:*debug-print-variable-alist* - (list* '(*print-level* . nil) - '(*print-length* . nil) - sb-debug:*debug-print-variable-alist*))) - (sb-debug:backtrace most-positive-fixnum s)) - #-:hunchentoot-sbcl-debug-print-variable-alist - (let ((sb-debug:*debug-print-level* nil) - (sb-debug:*debug-print-length* nil)) - (sb-debug:backtrace most-positive-fixnum s)))) \ No newline at end of file Modified: trunk/thirdparty/hunchentoot/hunchentoot.asd =================================================================== --- trunk/thirdparty/hunchentoot/hunchentoot.asd 2009-02-10 10:32:09 UTC (rev 4221) +++ trunk/thirdparty/hunchentoot/hunchentoot.asd 2009-02-10 10:45:45 UTC (rev 4222) @@ -69,7 +69,6 @@ (:file "misc") (:file "easy-handlers") (:file "headers") - (:file "get-backtrace") (:file "set-timeouts") (:file "connection-dispatcher") (:file "server") Modified: trunk/thirdparty/hunchentoot/packages.lisp =================================================================== --- trunk/thirdparty/hunchentoot/packages.lisp 2009-02-10 10:32:09 UTC (rev 4221) +++ trunk/thirdparty/hunchentoot/packages.lisp 2009-02-10 10:45:45 UTC (rev 4222) @@ -56,7 +56,6 @@ "*LISP-ERRORS-LOG-LEVEL*" "*LISP-WARNINGS-LOG-LEVEL*" "*LISTENER*" - "*LOG-LISP-BACKTRACES-P*" "*LOG-LISP-ERRORS-P*" "*LOG-LISP-WARNINGS-P*" "*METHODS-FOR-POST-PARAMETERS*" @@ -69,7 +68,6 @@ "*SESSION-GC-FREQUENCY*" "*SESSION-MAX-TIME*" "*SESSION-REMOVAL-HOOK*" - "*SHOW-LISP-BACKTRACES-P*" "*SHOW-LISP-ERRORS-P*" "*TMP-DIRECTORY*" "*USE-REMOTE-ADDR-FOR-SESSIONS*" @@ -145,7 +143,6 @@ "DISPATCH-REQUEST" "DO-SESSIONS" "ESCAPE-FOR-HTML" - "GET-BACKTRACE" "GET-PARAMETER" "GET-PARAMETERS" "GET-PARAMETERS*" Modified: trunk/thirdparty/hunchentoot/server.lisp =================================================================== --- trunk/thirdparty/hunchentoot/server.lisp 2009-02-10 10:32:09 UTC (rev 4221) +++ trunk/thirdparty/hunchentoot/server.lisp 2009-02-10 10:45:45 UTC (rev 4222) @@ -499,25 +499,13 @@ using START-OUTPUT. If all goes as planned, the function returns T." (let (*tmp-files* *headers-sent*) (unwind-protect - (let* ((*request* request) - backtrace) + (let* ((*request* request)) (multiple-value-bind (body error) (catch 'handler-done (handler-bind ((error (lambda (cond) - ;; only generate backtrace if needed - (setq backtrace - (and (or (and *show-lisp-errors-p* - *show-lisp-backtraces-p*) - (and *log-lisp-errors-p* - *log-lisp-backtraces-p*)) - (get-backtrace cond))) (when *log-lisp-errors-p* - (log-message* *lisp-errors-log-level* - "~A~:[~*~;~%~A~]" - cond - *log-lisp-backtraces-p* - backtrace)) + (log-message* *lisp-errors-log-level* "~A" cond)) ;; if the headers were already sent ;; the error happens within the body ;; and we have to close the stream @@ -528,11 +516,7 @@ (warning (lambda (cond) (when *log-lisp-warnings-p* - (log-message* *lisp-warnings-log-level* - "~A~:[~*~;~%~A~]" - cond - *log-lisp-backtraces-p* - backtrace))))) + (log-message* *lisp-warnings-log-level* "~A" cond))))) ;; skip dispatch if bad request (when (eql (return-code) +http-ok+) ;; now do the work @@ -540,12 +524,7 @@ (when error (setf (return-code *reply*) +http-internal-server-error+)) - (start-output :content (cond ((and error *show-lisp-errors-p*) - (format nil "<pre>~A~:[~*~;~%~%~A~]</pre>" - (escape-for-html (format nil "~A" error)) - *show-lisp-backtraces-p* - (escape-for-html (format nil "~A" backtrace)))) - (error + (start-output :content (cond (error "An error has occured.") (t body)))) t) Modified: trunk/thirdparty/hunchentoot/specials.lisp =================================================================== --- trunk/thirdparty/hunchentoot/specials.lisp 2009-02-10 10:32:09 UTC (rev 4221) +++ trunk/thirdparty/hunchentoot/specials.lisp 2009-02-10 10:45:45 UTC (rev 4222) @@ -198,22 +198,12 @@ (defvar *show-lisp-errors-p* nil "Whether Lisp errors should be shown in HTML output.") -(defvar *show-lisp-backtraces-p* nil - "Whether Lisp backtraces should be shown in HTML output when an -error occurs. Will only have an effect if *SHOW-LISP-ERRORS-P* is -also true.") - (defvar *log-lisp-errors-p* t "Whether Lisp errors should be logged.") (defvar *log-lisp-warnings-p* t "Whether Lisp warnings should be logged.") -(defvar *log-lisp-backtraces-p* nil - "Whether Lisp backtraces should be logged when an error or warning -occurs. Will only have an effect if *LOG-LISP-ERRORS-P* or -*LOG-LISP-BACKTRACES* are also true.") - (defvar *lisp-errors-log-level* :error "Log level for Lisp errors.")

1 0

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

10 Feb '09

Revision: 4221 Author: edi URL: http://bknr.net/trac/changeset/4221 Remove Unix files U trunk/thirdparty/hunchentoot/hunchentoot.asd D trunk/thirdparty/hunchentoot/unix-acl.lisp D trunk/thirdparty/hunchentoot/unix-clisp.lisp D trunk/thirdparty/hunchentoot/unix-cmu.lisp D trunk/thirdparty/hunchentoot/unix-lw.lisp D trunk/thirdparty/hunchentoot/unix-mcl.lisp D trunk/thirdparty/hunchentoot/unix-other.lisp D trunk/thirdparty/hunchentoot/unix-sbcl.lisp Modified: trunk/thirdparty/hunchentoot/hunchentoot.asd =================================================================== --- trunk/thirdparty/hunchentoot/hunchentoot.asd 2009-02-10 10:31:33 UTC (rev 4220) +++ trunk/thirdparty/hunchentoot/hunchentoot.asd 2009-02-10 10:32:09 UTC (rev 4221) @@ -70,13 +70,6 @@ (:file "easy-handlers") (:file "headers") (:file "get-backtrace") - #+(and :allegro :unix) (:file "unix-acl") - #+(and :clisp :unix) (:file "unix-clisp") - #+(and :cmu :unix) (:file "unix-cmu") - #+(and :lispworks :unix) (:file "unix-lw") - #+(and :openmcl :unix) (:file "unix-mcl") - #+(and :sbcl :unix (not :win32)) (:file "unix-sbcl") - #+(and (not (or :allegro :clisp :cmu :lispworks :openmcl :sbcl)) :unix) (:file "unix-other") (:file "set-timeouts") (:file "connection-dispatcher") (:file "server") Deleted: trunk/thirdparty/hunchentoot/unix-acl.lisp =================================================================== --- trunk/thirdparty/hunchentoot/unix-acl.lisp 2009-02-10 10:31:33 UTC (rev 4220) +++ trunk/thirdparty/hunchentoot/unix-acl.lisp 2009-02-10 10:32:09 UTC (rev 4221) @@ -1,53 +0,0 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/hunchentoot/unix-acl.lisp,v 1.6 2008/02/13 16:02:19 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) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (require "osi")) - -(defun setuid (uid) - "Sets the effective user ID of the current process to UID - see -setuid\(2)." - (excl.osi:setuid uid)) - -(defun setgid (gid) - "Sets the effective group ID of the current process to GID - -see setgid\(2)." - (excl.osi:setgid gid)) - -(defun get-uid-from-name (name) - "Returns the UID for the user named NAME." - (excl.osi:pwent-uid (or (excl.osi:getpwnam name) - (parameter-error "User ~S not found." name)))) - -(defun get-gid-from-name (name) - "Returns the GID for the group named NAME." - (excl.osi:grent-gid (or (excl.osi:getgrnam name) - (parameter-error "Group ~S not found." name)))) Deleted: trunk/thirdparty/hunchentoot/unix-clisp.lisp =================================================================== --- trunk/thirdparty/hunchentoot/unix-clisp.lisp 2009-02-10 10:31:33 UTC (rev 4220) +++ trunk/thirdparty/hunchentoot/unix-clisp.lisp 2009-02-10 10:32:09 UTC (rev 4221) @@ -1,51 +0,0 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10; -*- -;;; $Header: /usr/local/cvsrep/hunchentoot/unix-clisp.lisp,v 1.3 2008/02/13 16:03:10 edi Exp $ - -;;; Copyright (c) 2006, Luis Oliveira <loliveira(a)common-lisp.net>. -;;; Copyright (c) 2007, Anton Vodonosov <avodonosov(a)yandex.ru>. -;;; Copyright (c) 2007-2008, 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) - -(defun setuid (uid) - "Sets the effective user ID of the current process to UID - see -setuid\(2)." - (setf (posix:getuid) uid)) - -(defun setgid (gid) - "Sets the effective group ID of the current process to GID - -see setgid\(2)." - (setf (posix:getgid) gid)) - -(defun get-uid-from-name (name) - "Returns the UID for the user named NAME." - (posix:user-info-uid (posix:user-info name))) - -(defun get-gid-from-name (name) - "Returns the GID for the group named NAME." - (posix:user-info-gid (posix:user-info name))) Deleted: trunk/thirdparty/hunchentoot/unix-cmu.lisp =================================================================== --- trunk/thirdparty/hunchentoot/unix-cmu.lisp 2009-02-10 10:31:33 UTC (rev 4220) +++ trunk/thirdparty/hunchentoot/unix-cmu.lisp 2009-02-10 10:32:09 UTC (rev 4221) @@ -1,54 +0,0 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/hunchentoot/unix-cmu.lisp,v 1.6 2008/02/13 16:02:19 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) - -(defun setuid (uid) - "Sets the effective user ID of the current process to UID - see -setuid\(2)." - (multiple-value-bind (return-value errno) - (unix:unix-setuid uid) - (unless (and return-value (zerop return-value)) - (parameter-error "setuid failed: ~A" (unix:get-unix-error-msg errno))))) - -(defun setgid (gid) - "Sets the effective group ID of the current process to GID - -see setgid\(2)." - (multiple-value-bind (return-value errno) - (unix:unix-setgid gid) - (unless (and return-value (zerop return-value)) - (parameter-error "setgid failed: ~A" (unix:get-unix-error-msg errno))))) - -(defun get-uid-from-name (name) - "Returns the UID for the user named NAME." - (unix:user-info-uid (unix:unix-getpwnam name))) - -(defun get-gid-from-name (name) - "Returns the GID for the group named NAME." - (unix:group-info-gid (unix:unix-getgrnam name))) Deleted: trunk/thirdparty/hunchentoot/unix-lw.lisp =================================================================== --- trunk/thirdparty/hunchentoot/unix-lw.lisp 2009-02-10 10:31:33 UTC (rev 4220) +++ trunk/thirdparty/hunchentoot/unix-lw.lisp 2009-02-10 10:32:09 UTC (rev 4221) @@ -1,93 +0,0 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/hunchentoot/unix-lw.lisp,v 1.5 2008/02/13 16:02:19 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) - -(fli:define-foreign-function (%setuid "setuid") - ((uid :int)) - :result-type :int) - -(defun setuid (uid) - "Sets the effective user ID of the current process to UID - see -setuid\(2)." - (unless (zerop (%setuid uid)) - (parameter-error "setuid failed: ~A" (lw:get-unix-error (lw:errno-value))))) - -(fli:define-foreign-function (%setgid "setgid") - ((gid :int)) - :result-type :int) - -(defun setgid (gid) - "Sets the effective group ID of the current process to GID - -see setgid\(2)." - (unless (zerop (%setgid gid)) - (parameter-error "setgid failed: ~A" (lw:get-unix-error (lw:errno-value))))) - -(fli:define-c-struct passwd - (name (:pointer :char)) - (passwd (:pointer :char)) - (uid :int) - (gid :int) - (gecos (:pointer :char)) - (dir (:pointer :char)) - (shell (:pointer :char))) - -(fli:define-foreign-function (getpwnam "getpwnam") - ((name (:reference-pass :ef-mb-string))) - :result-type (:pointer passwd)) - -(defun get-uid-from-name (name) - "Returns the UID for the user named NAME." - (let ((passwd (getpwnam name))) - (when (fli:null-pointer-p passwd) - (let ((errno (lw:errno-value))) - (cond ((zerop errno) - (parameter-error "User ~S not found." name)) - (t (parameter-error "getpwnam failed: ~A" (lw:get-unix-error errno)))))) - (fli:foreign-slot-value passwd 'uid))) - -(fli:define-c-struct group - (name (:pointer :char)) - (passwd (:pointer :char)) - (gid :int) - (mem (:pointer (:pointer :char)))) - -(fli:define-foreign-function (getgrnam "getgrnam") - ((name (:reference-pass :ef-mb-string))) - :result-type (:pointer group)) - -(defun get-gid-from-name (name) - "Returns the GID for the group named NAME." - (let ((group (getgrnam name))) - (when (fli:null-pointer-p group) - (let ((errno (lw:errno-value))) - (cond ((zerop errno) - (parameter-error "Group ~S not found." name)) - (t (parameter-error "getgrnam failed: ~A" (lw:get-unix-error errno)))))) - (fli:foreign-slot-value group 'gid))) \ No newline at end of file Deleted: trunk/thirdparty/hunchentoot/unix-mcl.lisp =================================================================== --- trunk/thirdparty/hunchentoot/unix-mcl.lisp 2009-02-10 10:31:33 UTC (rev 4220) +++ trunk/thirdparty/hunchentoot/unix-mcl.lisp 2009-02-10 10:32:09 UTC (rev 4221) @@ -1,54 +0,0 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/hunchentoot/unix-mcl.lisp,v 1.7 2008/02/13 16:02:19 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) - -(defun setuid (uid) - "Sets the effective user ID of the current process to UID - see -setuid\(2)." - (let ((errno (ccl::setuid uid))) - (unless (zerop errno) - (parameter-error "setuid failed with errno ~A." errno)))) - -(defun setgid (gid) - "Sets the effective group ID of the current process to GID - -see setgid\(2)." - (let ((errno (ccl::setgid gid))) - (unless (zerop errno) - (parameter-error "setgid failed with errno ~A." errno)))) - -(defun get-uid-from-name (name) - "Returns the UID for the user named NAME." - (declare (ignore name)) - (not-implemented 'get-uid-from-name)) - -(defun get-gid-from-name (name) - "Returns the GID for the group named NAME." - (declare (ignore name)) - (not-implemented 'get-gid-from-name)) Deleted: trunk/thirdparty/hunchentoot/unix-other.lisp =================================================================== --- trunk/thirdparty/hunchentoot/unix-other.lisp 2009-02-10 10:31:33 UTC (rev 4220) +++ trunk/thirdparty/hunchentoot/unix-other.lisp 2009-02-10 10:32:09 UTC (rev 4221) @@ -1,50 +0,0 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/hunchentoot/unix-lw.lisp,v 1.5 2008/02/13 16:02:19 edi Exp $ - -;;; Copyright (c) 2008, 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) - -(defun setuid (uid) - "Stub." - (declare (ignore uid)) - (not-implemented 'setuid)) - -(defun setgid (gid) - "Stub." - (declare (ignore gid)) - (not-implemented 'setgid)) - -(defun get-uid-from-name (name) - "Stub." - (declare (ignore name)) - (not-implemented 'get-uid-from-name)) - -(defun get-gid-from-name (name) - "Stub." - (declare (ignore name)) - (not-implemented 'get-gid-from-name)) Deleted: trunk/thirdparty/hunchentoot/unix-sbcl.lisp =================================================================== --- trunk/thirdparty/hunchentoot/unix-sbcl.lisp 2009-02-10 10:31:33 UTC (rev 4220) +++ trunk/thirdparty/hunchentoot/unix-sbcl.lisp 2009-02-10 10:32:09 UTC (rev 4221) @@ -1,57 +0,0 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/hunchentoot/unix-sbcl.lisp,v 1.8 2008/02/13 16:02:19 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) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (when (and (eq (nth-value 1 (find-symbol "GETGRNAM" :sb-posix)) :external) - (eq (nth-value 1 (find-symbol "GROUP-GID" :sb-posix)) :external)) - (pushnew :sb-posix-has-getgrnam *features*))) - -(defun setuid (uid) - "Sets the effective user ID of the current process to UID - see -setuid\(2)." - (sb-posix:setuid uid)) - -(defun setgid (gid) - "Sets the effective group ID of the current process to GID - -see setgid\(2)." - (sb-posix:setgid gid)) - -(defun get-uid-from-name (name) - "Returns the UID for the user named NAME." - (sb-posix:passwd-uid (sb-posix:getpwnam name))) - -(defun get-gid-from-name (name) - "Returns the GID for the group named NAME." - (declare (ignorable name)) - #+:sb-posix-has-getgrnam - (sb-posix:group-gid (sb-posix:getgrnam name)) - #-:sb-posix-has-getgrnam - (hunchentoot-error "You need a version of SBCL with SB-POSIX:GETGRNAM \(1.0.10.31 or higher)."))

1 0

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

10 Feb '09

Revision: 4220 Author: edi URL: http://bknr.net/trac/changeset/4220 Remove setuid/setgid stuff U trunk/thirdparty/hunchentoot/server.lisp Modified: trunk/thirdparty/hunchentoot/server.lisp =================================================================== --- trunk/thirdparty/hunchentoot/server.lisp 2009-02-10 10:30:10 UTC (rev 4219) +++ trunk/thirdparty/hunchentoot/server.lisp 2009-02-10 10:31:33 UTC (rev 4220) @@ -212,8 +212,6 @@ input-chunking-p connection-timeout persistent-connections-p read-timeout write-timeout - #+(and :unix (not :win32)) setuid - #+(and :unix (not :win32)) setgid #-:hunchentoot-no-ssl #-:hunchentoot-no-ssl #-:hunchentoot-no-ssl ssl-certificate-file ssl-privatekey-file ssl-privatekey-password access-logger) @@ -279,12 +277,6 @@ want to specify this argument unless you want to have non-standard threading behavior. See the documentation for more information. -On Unix you can use SETUID and SETGID to change the UID and GID of the -process directly after the server has been started. \(You might want -to do this if you're using a privileged port like 80.) SETUID and -SETGID can be integers \(the actual IDs) or strings \(for the user and -group name respectively). - MESSAGE-LOGGER is a designator for a function to call to log messages by the server. It must accept a severity level for the message \(one of :INFO, :WARNING, or :ERROR), a format string, and an arbitary @@ -322,18 +314,6 @@ 'server args))) (start server) - #+(and :unix (not :win32)) - (when setgid - ;; we must make sure to call setgid before we call setuid or - ;; suddenly we aren't root anymore... - (etypecase setgid - (integer (setgid setgid)) - (string (setgid (get-gid-from-name setgid))))) - #+(and :unix (not :win32)) - (when setuid - (etypecase setuid - (integer (setuid setuid)) - (string (setuid (get-uid-from-name setuid))))) server)) (defun stop-server (server)

1 0

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

10 Feb '09

Revision: 4219 Author: edi URL: http://bknr.net/trac/changeset/4219 Rename, part 2 A trunk/thirdparty/hunchentoot/connection-dispatcher.lisp D trunk/thirdparty/hunchentoot/connection-manager.lisp U trunk/thirdparty/hunchentoot/hunchentoot.asd Copied: trunk/thirdparty/hunchentoot/connection-dispatcher.lisp (from rev 4218, trunk/thirdparty/hunchentoot/connection-manager.lisp) =================================================================== --- trunk/thirdparty/hunchentoot/connection-dispatcher.lisp (rev 0) +++ trunk/thirdparty/hunchentoot/connection-dispatcher.lisp 2009-02-10 10:30:10 UTC (rev 4219) @@ -0,0 +1,143 @@ +;;; -*- 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) + +;;; The connection-dispatcher protocol defines how Hunchentoot schedules +;;; request execution to worker threads or for inline execution. + +(defclass connection-dispatcher () + ((server :initarg :server + :reader server + :documentation "The Hunchentoot server 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 server instance.")) + +(defgeneric execute-acceptor (connection-dispatcher) + (: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 server, taken from +the SERVER slot of the connection dispatcher instance. + +In a multi-threaded environment, the connection dispatcher 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) + (: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 +connection by calling the START-REQUEST-PROCESSING function of the +server instance, taken from the SERVER slot in the connection dispatcher +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 separate thread. In a single-threaded environment, this function +is called directly.")) + +(defgeneric shutdown (connection-dispatcher) + (:documentation "Terminate all threads that are currently associated +with the connection dispatcher, if any.") + (:method ((manager t)) + #+:lispworks + (when-let (acceptor (server-acceptor (server manager))) + ;; kill the main acceptor process, see LW documentation for + ;; COMM:START-UP-SERVER + (mp:process-kill acceptor)))) + +(defclass single-threaded-connection-dispatcher (connection-dispatcher) + () + (:documentation "Connection Dispatcher that runs synchronously in the +thread that invoked the START-SERVER function.")) + +(defmethod execute-acceptor ((manager single-threaded-connection-dispatcher)) + (accept-connections (server manager))) + +(defmethod handle-incoming-connection ((manager single-threaded-connection-dispatcher) socket) + (process-connection (server manager) socket)) + +(defclass one-thread-per-connection-dispatcher (connection-dispatcher) + ((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 +listening to incoming requests and one thread for each incoming +connection.")) + +(defmethod execute-acceptor ((manager one-thread-per-connection-dispatcher)) + #+:lispworks + (accept-connections (server manager)) + #-:lispworks + (setf (acceptor-process manager) + (bt:make-thread (lambda () + (accept-connections (server manager))) + :name (format nil "Hunchentoot acceptor \(~A:~A)" + (or (server-address (server manager)) "*") + (server-port (server manager)))))) + +#-:lispworks +(defmethod shutdown ((manager one-thread-per-connection-dispatcher)) + (loop + while (bt:thread-alive-p (acceptor-process manager)) + do (sleep 1))) + +#+:lispworks +(defmethod handle-incoming-connection ((manager one-thread-per-connection-dispatcher) 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 + (server manager) handle)) + +#-: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 ((manager one-thread-per-connection-dispatcher) socket) + (bt:make-thread (lambda () + (process-connection (server manager) socket)) + :name (format nil "Hunchentoot worker \(client: ~A)" (client-as-string socket)))) Deleted: trunk/thirdparty/hunchentoot/connection-manager.lisp =================================================================== --- trunk/thirdparty/hunchentoot/connection-manager.lisp 2009-02-10 10:28:58 UTC (rev 4218) +++ trunk/thirdparty/hunchentoot/connection-manager.lisp 2009-02-10 10:30:10 UTC (rev 4219) @@ -1,143 +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) - -;;; The connection-dispatcher protocol defines how Hunchentoot schedules -;;; request execution to worker threads or for inline execution. - -(defclass connection-dispatcher () - ((server :initarg :server - :reader server - :documentation "The Hunchentoot server 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 server instance.")) - -(defgeneric execute-acceptor (connection-dispatcher) - (: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 server, taken from -the SERVER slot of the connection dispatcher instance. - -In a multi-threaded environment, the connection dispatcher 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) - (: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 -connection by calling the START-REQUEST-PROCESSING function of the -server instance, taken from the SERVER slot in the connection dispatcher -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 separate thread. In a single-threaded environment, this function -is called directly.")) - -(defgeneric shutdown (connection-dispatcher) - (:documentation "Terminate all threads that are currently associated -with the connection dispatcher, if any.") - (:method ((manager t)) - #+:lispworks - (when-let (acceptor (server-acceptor (server manager))) - ;; kill the main acceptor process, see LW documentation for - ;; COMM:START-UP-SERVER - (mp:process-kill acceptor)))) - -(defclass single-threaded-connection-dispatcher (connection-dispatcher) - () - (:documentation "Connection Dispatcher that runs synchronously in the -thread that invoked the START-SERVER function.")) - -(defmethod execute-acceptor ((manager single-threaded-connection-dispatcher)) - (accept-connections (server manager))) - -(defmethod handle-incoming-connection ((manager single-threaded-connection-dispatcher) socket) - (process-connection (server manager) socket)) - -(defclass one-thread-per-connection-dispatcher (connection-dispatcher) - ((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 -listening to incoming requests and one thread for each incoming -connection.")) - -(defmethod execute-acceptor ((manager one-thread-per-connection-dispatcher)) - #+:lispworks - (accept-connections (server manager)) - #-:lispworks - (setf (acceptor-process manager) - (bt:make-thread (lambda () - (accept-connections (server manager))) - :name (format nil "Hunchentoot acceptor \(~A:~A)" - (or (server-address (server manager)) "*") - (server-port (server manager)))))) - -#-:lispworks -(defmethod shutdown ((manager one-thread-per-connection-dispatcher)) - (loop - while (bt:thread-alive-p (acceptor-process manager)) - do (sleep 1))) - -#+:lispworks -(defmethod handle-incoming-connection ((manager one-thread-per-connection-dispatcher) 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 - (server manager) handle)) - -#-: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 ((manager one-thread-per-connection-dispatcher) socket) - (bt:make-thread (lambda () - (process-connection (server manager) socket)) - :name (format nil "Hunchentoot worker \(client: ~A)" (client-as-string socket)))) Modified: trunk/thirdparty/hunchentoot/hunchentoot.asd =================================================================== --- trunk/thirdparty/hunchentoot/hunchentoot.asd 2009-02-10 10:28:58 UTC (rev 4218) +++ trunk/thirdparty/hunchentoot/hunchentoot.asd 2009-02-10 10:30:10 UTC (rev 4219) @@ -78,7 +78,7 @@ #+(and :sbcl :unix (not :win32)) (:file "unix-sbcl") #+(and (not (or :allegro :clisp :cmu :lispworks :openmcl :sbcl)) :unix) (:file "unix-other") (:file "set-timeouts") - (:file "connection-manager") + (:file "connection-dispatcher") (:file "server") #-:hunchentoot-no-ssl (:file "ssl")))

1 0

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

10 Feb '09

Revision: 4218 Author: edi URL: http://bknr.net/trac/changeset/4218 Rename, part 1 U trunk/thirdparty/hunchentoot/connection-manager.lisp U trunk/thirdparty/hunchentoot/server.lisp U trunk/thirdparty/hunchentoot/specials.lisp Modified: trunk/thirdparty/hunchentoot/connection-manager.lisp =================================================================== --- trunk/thirdparty/hunchentoot/connection-manager.lisp 2009-02-10 09:32:46 UTC (rev 4217) +++ trunk/thirdparty/hunchentoot/connection-manager.lisp 2009-02-10 10:28:58 UTC (rev 4218) @@ -29,46 +29,46 @@ (in-package :hunchentoot) -;;; The connection-manager protocol defines how Hunchentoot schedules +;;; The connection-dispatcher protocol defines how Hunchentoot schedules ;;; request execution to worker threads or for inline execution. -(defclass connection-manager () +(defclass connection-dispatcher () ((server :initarg :server :reader server :documentation "The Hunchentoot server instance that this -connection manager works for.")) - (:documentation "Base class for all connection managers classes. +connection dispatcher works for.")) + (:documentation "Base class for all connection dispatchers classes. Its purpose is to carry the back pointer to the server instance.")) -(defgeneric execute-acceptor (connection-manager) +(defgeneric execute-acceptor (connection-dispatcher) (: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 server, taken from -the SERVER slot of the connection manager instance. +the SERVER slot of the connection dispatcher instance. -In a multi-threaded environment, the connection manager starts a new +In a multi-threaded environment, the connection dispatcher 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-manager socket) +(defgeneric handle-incoming-connection (connection-dispatcher 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 manager starts processing requests on the incoming +The connection dispatcher starts processing requests on the incoming connection by calling the START-REQUEST-PROCESSING function of the -server instance, taken from the SERVER slot in the connection manager +server instance, taken from the SERVER slot in the connection dispatcher instance. The SOCKET argument is passed to START-REQUEST-PROCESSING as argument. -In a multi-threaded environment, the connection manager runs this function +In a multi-threaded environment, the connection dispatcher runs this function in a separate thread. In a single-threaded environment, this function is called directly.")) -(defgeneric shutdown (connection-manager) +(defgeneric shutdown (connection-dispatcher) (:documentation "Terminate all threads that are currently associated -with the connection manager, if any.") +with the connection dispatcher, if any.") (:method ((manager t)) #+:lispworks (when-let (acceptor (server-acceptor (server manager))) @@ -76,27 +76,27 @@ ;; COMM:START-UP-SERVER (mp:process-kill acceptor)))) -(defclass single-threaded-connection-manager (connection-manager) +(defclass single-threaded-connection-dispatcher (connection-dispatcher) () - (:documentation "Connection manager that runs synchronously in the + (:documentation "Connection Dispatcher that runs synchronously in the thread that invoked the START-SERVER function.")) -(defmethod execute-acceptor ((manager single-threaded-connection-manager)) +(defmethod execute-acceptor ((manager single-threaded-connection-dispatcher)) (accept-connections (server manager))) -(defmethod handle-incoming-connection ((manager single-threaded-connection-manager) socket) +(defmethod handle-incoming-connection ((manager single-threaded-connection-dispatcher) socket) (process-connection (server manager) socket)) -(defclass one-thread-per-connection-manager (connection-manager) +(defclass one-thread-per-connection-dispatcher (connection-dispatcher) ((acceptor-process :accessor acceptor-process :documentation "Process that accepts incoming connections and dispatches them to new processes for request execution.")) - (:documentation "Connection manager that starts one thread for + (:documentation "Connection Dispatcher that starts one thread for listening to incoming requests and one thread for each incoming connection.")) -(defmethod execute-acceptor ((manager one-thread-per-connection-manager)) +(defmethod execute-acceptor ((manager one-thread-per-connection-dispatcher)) #+:lispworks (accept-connections (server manager)) #-:lispworks @@ -108,13 +108,13 @@ (server-port (server manager)))))) #-:lispworks -(defmethod shutdown ((manager one-thread-per-connection-manager)) +(defmethod shutdown ((manager one-thread-per-connection-dispatcher)) (loop while (bt:thread-alive-p (acceptor-process manager)) do (sleep 1))) #+:lispworks -(defmethod handle-incoming-connection ((manager one-thread-per-connection-manager) handle) +(defmethod handle-incoming-connection ((manager one-thread-per-connection-dispatcher) handle) (incf *worker-counter*) ;; check if we need to perform a global GC (when (and *cleanup-interval* @@ -137,7 +137,7 @@ port)))) #-:lispworks -(defmethod handle-incoming-connection ((manager one-thread-per-connection-manager) socket) +(defmethod handle-incoming-connection ((manager one-thread-per-connection-dispatcher) socket) (bt:make-thread (lambda () (process-connection (server manager) socket)) :name (format nil "Hunchentoot worker \(client: ~A)" (client-as-string socket)))) Modified: trunk/thirdparty/hunchentoot/server.lisp =================================================================== --- trunk/thirdparty/hunchentoot/server.lisp 2009-02-10 09:32:46 UTC (rev 4217) +++ trunk/thirdparty/hunchentoot/server.lisp 2009-02-10 10:28:58 UTC (rev 4218) @@ -74,10 +74,10 @@ specified in (fractional) seconds. The precise semantics of this parameter is determined by the underlying Lisp's implementation of socket timeouts.") - (connection-manager :initarg :connection-manager + (connection-dispatcher :initarg :connection-dispatcher :initform nil - :reader server-connection-manager - :documentation "The connection manager that is + :reader server-connection-dispatcher + :documentation "The connection dispatcher that is responsible for listening to new connections and scheduling them for execution.") #+:lispworks @@ -125,8 +125,8 @@ information about a running Hunchentoot server instance.")) (defmethod initialize-instance :after ((server server) - &key connection-manager-class - connection-manager-arguments + &key connection-dispatcher-class + connection-dispatcher-arguments (threaded *supports-threads-p* threaded-specified-p) (persistent-connections-p threaded @@ -136,12 +136,12 @@ connection-timeout-provided-p) (read-timeout nil read-timeout-provided-p) (write-timeout nil write-timeout-provided-p)) - "The CONNECTION-MANAGER-CLASS and CONNECTION-MANAGER-ARGUMENTS + "The CONNECTION-DISPATCHER-CLASS and CONNECTION-DISPATCHER-ARGUMENTS arguments to the creation of a server instance determine the -connection manager instance that is created. THREADED is the user -friendly version of the CONNECTION-MANAGER-CLASS option. If it is -NIL, an unthreaded connection manager is used. It is an error to -specify both THREADED and a CONNECTION-MANAGER-CLASS argument. +connection dispatcher instance that is created. THREADED is the user +friendly version of the CONNECTION-DISPATCHER-CLASS option. If it is +NIL, an unthreaded connection dispatcher is used. It is an error to +specify both THREADED and a CONNECTION-DISPATCHER-CLASS argument. The PERSISTENT-CONNECTIONS-P keyword argument defaults to the value of the THREADED keyword argument but can be overridden. @@ -151,19 +151,19 @@ value. If either of READ-TIMEOUT or WRITE-TIMEOUT is specified, CONNECTION-TIMEOUT is not used and may not be supplied." (declare (ignore read-timeout write-timeout)) - (when (and threaded-specified-p connection-manager-class) - (parameter-error "Can't use both THREADED and CONNECTION-MANAGER-CLASS arguments.")) + (when (and threaded-specified-p connection-dispatcher-class) + (parameter-error "Can't use both THREADED and CONNECTION-DISPATCHER-CLASS arguments.")) (unless persistent-connections-specified-p (setf (server-persistent-connections-p server) persistent-connections-p)) - (unless (server-connection-manager server) - (setf (slot-value server 'connection-manager) + (unless (server-connection-dispatcher server) + (setf (slot-value server 'connection-dispatcher) (apply #'make-instance - (or connection-manager-class + (or connection-dispatcher-class (if threaded - 'one-thread-per-connection-manager - 'single-threaded-connection-manager)) + 'one-thread-per-connection-dispatcher + 'single-threaded-connection-dispatcher)) :server server - connection-manager-arguments))) + connection-dispatcher-arguments))) (if (or read-timeout-provided-p write-timeout-provided-p) (when connection-timeout-provided-p (parameter-error "Can't have both CONNECTION-TIMEOUT and either of READ-TIMEOUT and WRITE-TIMEOUT.")) @@ -196,13 +196,13 @@ connections.") (:method ((server server)) (start-listening server) - (execute-acceptor (server-connection-manager server)))) + (execute-acceptor (server-connection-dispatcher server)))) (defgeneric stop (server) (:documentation "Stop the SERVER so that it does no longer accept requests.") (:method ((server server)) (setf (server-shutdown-p server) t) - (shutdown (server-connection-manager server)) + (shutdown (server-connection-dispatcher server)) #-:lispworks (usocket:socket-close (server-listen-socket server)))) @@ -274,7 +274,7 @@ and not all implementations provide for separate read and write timeout parameter setting. -CONNECTION-MANAGER-CLASS specifies the name of the class to instantiate +CONNECTION-DISPATCHER-CLASS specifies the name of the class to instantiate for managing how connections are mapped to threads. You don't normally want to specify this argument unless you want to have non-standard threading behavior. See the documentation for more information. @@ -340,12 +340,8 @@ "Stops the Hunchentoot server SERVER." (stop server)) -;; connection manager API +;; connection dispatcher API -(defconstant +new-connection-wait-time+ 2 - "Time in seconds to wait for a new connection to arrive before -performing a cleanup run.") - (defgeneric start-listening (server) (:documentation "Sets up a listen socket for the given SERVER and enables it to listen for incoming connections. This function is @@ -370,7 +366,7 @@ :function (lambda (handle) (unless (server-shutdown-p server) (handle-incoming-connection - (server-connection-manager server) handle))) + (server-connection-dispatcher server) handle))) ;; wait until the server was successfully started ;; or an error condition is returned :wait t) @@ -388,7 +384,7 @@ (defgeneric accept-connections (server) (:documentation "In a loop, accepts a connection and -dispatches it to the server's connection manager object for processing +dispatches it to the server's connection dispatcher object for processing using HANDLE-INCOMING-CONNECTION.") (:method ((server server)) #+:lispworks @@ -403,7 +399,7 @@ (set-timeouts client-connection (server-read-timeout server) (server-write-timeout server)) - (handle-incoming-connection (server-connection-manager server) + (handle-incoming-connection (server-connection-dispatcher server) client-connection)) ;; ignore condition (usocket:connection-aborted-error ())))))) @@ -445,7 +441,7 @@ finally (setf (return-code reply) +http-not-found+)))) (defgeneric process-connection (server socket) - (:documentation "This function is called by the connection manager + (:documentation "This function is called by the connection dispatcher when a new client connection has been established. Arguments are the SERVER object and a usocket socket stream object \(or a LispWorks socket handle) in SOCKET. It reads the request headers and hands over Modified: trunk/thirdparty/hunchentoot/specials.lisp =================================================================== --- trunk/thirdparty/hunchentoot/specials.lisp 2009-02-10 09:32:46 UTC (rev 4217) +++ trunk/thirdparty/hunchentoot/specials.lisp 2009-02-10 10:28:58 UTC (rev 4218) @@ -327,6 +327,10 @@ #+:lispworks t #-:lispworks bt:*supports-threads-p*) +(defconstant +new-connection-wait-time+ 2 + "Time in seconds to wait for a new connection to arrive before +performing a cleanup run.") + (pushnew :hunchentoot *features*) ;; stuff for Nikodemus Siivola's HYPERDOC

1 0

[bknr-cvs] edi changed trunk/thirdparty/chunga/conditions.lisp
by BKNR Commits 10 Feb '09

10 Feb '09

Revision: 4217 Author: edi URL: http://bknr.net/trac/changeset/4217 Forgot this file A trunk/thirdparty/chunga/conditions.lisp Added: trunk/thirdparty/chunga/conditions.lisp =================================================================== --- trunk/thirdparty/chunga/conditions.lisp (rev 0) +++ trunk/thirdparty/chunga/conditions.lisp 2009-02-10 09:32:46 UTC (rev 4217) @@ -0,0 +1,84 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: ODD-STREAMS; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/odd-streams/conditions.lisp,v 1.5 2007/12/31 01:08:45 edi Exp $ + +;;; Copyright (c) 2008-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 :chunga) + +(define-condition chunga-condition (condition) + () + (:documentation "Superclass for all conditions related to Chunga.")) + +(define-condition chunga-error (chunga-condition stream-error) + () + (:documentation "Superclass for all errors related to Chunga. This +is a subtype of STREAM-ERROR, so STREAM-ERROR-STREAM can be used to +access the offending stream.")) + +(define-condition chunga-simple-error (chunga-error simple-condition) + () + (:documentation "Like CHUNGA-ERROR but with formatting capabilities.")) + +(define-condition parameter-error (chunga-simple-error) + () + (:documentation "Signalled if a function was called with +inconsistent or illegal parameters.")) + +(define-condition syntax-error (chunga-simple-error) + () + (:documentation "Signalled if Chunga encounters wrong or unknown +syntax when reading data.")) + +(define-condition chunga-warning (chunga-condition warning) + () + (:documentation "Superclass for all warnings related to Chunga.")) + +(define-condition chunga-simple-warning (chunga-warning simple-condition) + () + (:documentation "Like CHUNGA-WARNING but with formatting capabilities.")) + +(define-condition input-chunking-unexpected-end-of-file (chunga-error) + () + (:documentation "A condition of this type is signaled if we reach an +unexpected EOF on a chunked stream with input chunking enabled.")) + +(define-condition input-chunking-body-corrupted (chunga-error) + ((last-char :initarg :last-char + :documentation "The \(unexpected) character which was read.") + (expected-chars :initarg :expected-chars + :documentation "The characters which were expected. +A list of characters or one single character.")) + (:report (lambda (condition stream) + (with-slots (last-char expected-chars) + condition + (format stream "Chunked stream ~S seems to be corrupted. +Read character ~S, but expected ~:[a member of ~S~;~S~]." + (stream-error-stream condition) + last-char (atom expected-chars) expected-chars)))) + (:documentation "A condition of this type is signaled if an +unexpected character \(octet) is read while reading from a chunked +stream with input chunking enabled."))

1 0

[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/doc/clixdoc.xsl
by BKNR Commits 09 Feb '09

09 Feb '09

Revision: 4216 Author: hans URL: http://bknr.net/trac/changeset/4216 Reworked U trunk/thirdparty/hunchentoot/doc/clixdoc.xsl Modified: trunk/thirdparty/hunchentoot/doc/clixdoc.xsl =================================================================== --- trunk/thirdparty/hunchentoot/doc/clixdoc.xsl 2009-02-09 14:57:39 UTC (rev 4215) +++ trunk/thirdparty/hunchentoot/doc/clixdoc.xsl 2009-02-09 15:25:05 UTC (rev 4216) @@ -39,7 +39,7 @@ omit-xml-declaration="yes" doctype-public="-//W3C//DTD HTML 4.0 Strict//EN" /> - <xsl:key name="index-entries" match="clix:*[@name]" use="@name" /> + <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"> @@ -78,9 +78,10 @@ <xsl:template match="clix:function"> + <xsl:call-template name="make-anchor"/> [<xsl:call-template name="nice-entry-type-name"/>] - <xsl:call-template name="make-anchor"/> + <xsl:call-template name="render-title"/> <xsl:value-of select="' '"/> <xsl:apply-templates select="clix:lambda-list"/> <xsl:if test="clix:returns"> @@ -95,20 +96,16 @@ <xsl:template match="clix:reader"> + <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> @@ -117,119 +114,48 @@ <xsl:template match="clix:writer"> + <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> - <blockquote> - <xsl:apply-templates select="clix:description"/> - </blockquote> - - </xsl:template> - - <xsl:template match="clix:accessor"> - - [<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"/> + <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"/> - - <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:if> <blockquote> <xsl:apply-templates select="clix:description"/> </blockquote> </xsl:template> - <xsl:template match="clix:special-variable"> + <xsl:template match="clix:accessor"> + <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"/> - </a> - <blockquote> - <xsl:apply-templates select="clix:description"/> - </blockquote> - - </xsl:template> - - <xsl:template match="clix:class"> - - [<xsl:call-template name="nice-entry-type-name"/>] + <xsl:call-template name="render-title"/> + <xsl:value-of select="' '"/> + <xsl:apply-templates select="clix:lambda-list"/> + => + <xsl:value-of select="clix:returns"/> - <a class="none"> - <xsl:attribute name="name"> - <xsl:value-of select="translate(@name, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 'abcdefghijklmnopqrstuvwxyz')"/> - </xsl:attribute> - <xsl:value-of select="@name"/> - </a> + <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:condition"> + <xsl:template match="clix:special-variable | clix:class | clix:condition | clix:symbol | clix:constant"> - [<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"/> - </a> - <blockquote> - <xsl:apply-templates select="clix:description"/> - </blockquote> - - </xsl:template> - - <xsl:template match="clix:symbol"> - - [<xsl:call-template name="nice-entry-type-name"/>] - <xsl:call-template name="make-anchor"/> - <blockquote> - <xsl:apply-templates select="clix:description"/> - </blockquote> - - </xsl:template> - - <xsl:template match="clix:constant"> - [<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"/> - </a> + <xsl:call-template name="render-title"/> <blockquote> <xsl:apply-templates select="clix:description"/> </blockquote> @@ -237,10 +163,7 @@ </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> @@ -270,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> @@ -351,14 +261,15 @@ <xsl:attribute name="name"> <xsl:value-of select="@name"/> </xsl:attribute> - <xsl:value-of select="@name"/> </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:value-of select="@name"/></xsl:with-param> + <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> @@ -378,6 +289,27 @@ </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"> @@ -394,10 +326,13 @@ <xsl:attribute name="name"> <xsl:call-template name="make-anchor-name"/> </xsl:attribute> - <xsl:value-of select="@name"/> </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'"> @@ -434,6 +369,7 @@ <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>

1 0