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

[bknr-cvs] r2452 - in branches/trunk-reorg/thirdparty/slime: . CVS contrib contrib/CVS doc/CVS
by hhubner＠common-lisp.net 07 Feb '08

07 Feb '08

Author: hhubner Date: Thu Feb 7 03:32:58 2008 New Revision: 2452 Removed: branches/trunk-reorg/thirdparty/slime/CVS/Entries.Log Modified: branches/trunk-reorg/thirdparty/slime/CVS/Entries branches/trunk-reorg/thirdparty/slime/ChangeLog branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp branches/trunk-reorg/thirdparty/slime/contrib/swank-fancy-inspector.lisp branches/trunk-reorg/thirdparty/slime/contrib/swank-presentation-streams.lisp branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries branches/trunk-reorg/thirdparty/slime/slime-autoloads.el branches/trunk-reorg/thirdparty/slime/slime.el branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp branches/trunk-reorg/thirdparty/slime/swank-allegro.lisp branches/trunk-reorg/thirdparty/slime/swank-backend.lisp branches/trunk-reorg/thirdparty/slime/swank-clisp.lisp branches/trunk-reorg/thirdparty/slime/swank-cmucl.lisp branches/trunk-reorg/thirdparty/slime/swank-corman.lisp branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp branches/trunk-reorg/thirdparty/slime/swank-lispworks.lisp branches/trunk-reorg/thirdparty/slime/swank-loader.lisp branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp branches/trunk-reorg/thirdparty/slime/swank-scl.lisp branches/trunk-reorg/thirdparty/slime/swank.lisp Log: delete unwanted file Modified: branches/trunk-reorg/thirdparty/slime/CVS/Entries ============================================================================== --- branches/trunk-reorg/thirdparty/slime/CVS/Entries (original) +++ branches/trunk-reorg/thirdparty/slime/CVS/Entries Thu Feb 7 03:32:58 2008 @@ -1,35 +1,35 @@ D/contrib//// D/doc//// -/.cvsignore/1.5/Sun Apr 8 19:23:57 2007// -/ChangeLog/1.1274/Sun Jan 27 22:03:20 2008// -/HACKING/1.8/Sun Jan 27 22:03:20 2008// -/NEWS/1.9/Sun Jan 27 22:03:20 2008// -/PROBLEMS/1.8/Sun Jan 27 22:03:20 2008// -/README/1.14/Sun Jan 27 22:03:20 2008// -/hyperspec.el/1.11/Sun Jan 27 22:03:20 2008// -/metering.lisp/1.4/Sun Jan 27 22:03:20 2008// -/mkdist.sh/1.7/Sun Jan 27 22:03:20 2008// -/nregex.lisp/1.4/Sun Jan 27 22:03:20 2008// -/sbcl-pprint-patch.lisp/1.1/Sun Jan 27 22:03:20 2008// -/slime-autoloads.el/1.3/Sun Jan 27 22:03:20 2008// -/slime.el/1.896/Sun Jan 27 22:03:20 2008// -/swank-abcl.lisp/1.44/Sun Jan 27 22:03:20 2008// -/swank-allegro.lisp/1.98/Sun Jan 27 22:03:20 2008// -/swank-backend.lisp/1.126/Sun Jan 27 22:03:21 2008// -/swank-clisp.lisp/1.64/Sun Jan 27 22:03:21 2008// -/swank-cmucl.lisp/1.175/Sun Jan 27 22:03:21 2008// -/swank-corman.lisp/1.11/Sun Jan 27 22:03:21 2008// -/swank-ecl.lisp/1.11/Sun Jan 27 22:03:21 2008// -/swank-gray.lisp/1.10/Sun Jan 27 22:03:21 2008// -/swank-lispworks.lisp/1.93/Sun Jan 27 22:03:21 2008// -/swank-loader.lisp/1.75/Sun Jan 27 22:03:21 2008// -/swank-openmcl.lisp/1.120/Sun Jan 27 22:03:21 2008// -/swank-sbcl.lisp/1.187/Sun Jan 27 22:03:21 2008// -/swank-scl.lisp/1.14/Sun Jan 27 22:03:21 2008// -/swank-source-file-cache.lisp/1.8/Sun Jan 27 22:03:21 2008// -/swank-source-path-parser.lisp/1.18/Sun Jan 27 22:03:21 2008// -/swank.asd/1.5/Sun Jan 27 22:03:21 2008// -/swank.lisp/1.523/Sun Jan 27 22:03:21 2008// -/test-all.sh/1.2/Sun Jan 27 22:03:21 2008// -/test.sh/1.9/Sun Jan 27 22:03:21 2008// -/xref.lisp/1.2/Sun Jan 27 22:03:21 2008// +/.cvsignore/1.5/Thu Oct 11 14:10:25 2007// +/ChangeLog/1.1282/Thu Feb 7 08:07:30 2008// +/HACKING/1.8/Thu Oct 11 14:10:25 2007// +/NEWS/1.9/Sun Dec 2 04:22:09 2007// +/PROBLEMS/1.8/Thu Oct 11 14:10:25 2007// +/README/1.14/Thu Oct 11 14:10:25 2007// +/hyperspec.el/1.11/Thu Oct 11 14:10:25 2007// +/metering.lisp/1.4/Thu Oct 11 14:10:25 2007// +/mkdist.sh/1.7/Thu Oct 11 14:10:25 2007// +/nregex.lisp/1.4/Thu Oct 11 14:10:25 2007// +/sbcl-pprint-patch.lisp/1.1/Thu Oct 11 14:10:25 2007// +/slime-autoloads.el/1.4/Thu Feb 7 08:07:30 2008// +/slime.el/1.901/Thu Feb 7 08:07:31 2008// +/swank-abcl.lisp/1.45/Thu Feb 7 08:07:31 2008// +/swank-allegro.lisp/1.99/Thu Feb 7 08:07:31 2008// +/swank-backend.lisp/1.127/Thu Feb 7 08:07:31 2008// +/swank-clisp.lisp/1.65/Thu Feb 7 08:07:31 2008// +/swank-cmucl.lisp/1.176/Thu Feb 7 08:07:31 2008// +/swank-corman.lisp/1.13/Thu Feb 7 08:07:31 2008// +/swank-ecl.lisp/1.12/Thu Feb 7 08:07:31 2008// +/swank-gray.lisp/1.10/Thu Oct 11 14:10:25 2007// +/swank-lispworks.lisp/1.94/Thu Feb 7 08:07:31 2008// +/swank-loader.lisp/1.77/Thu Feb 7 08:07:31 2008// +/swank-openmcl.lisp/1.122/Thu Feb 7 08:07:31 2008// +/swank-sbcl.lisp/1.189/Thu Feb 7 08:07:31 2008// +/swank-scl.lisp/1.15/Thu Feb 7 08:07:31 2008// +/swank-source-file-cache.lisp/1.8/Thu Oct 11 14:10:25 2007// +/swank-source-path-parser.lisp/1.18/Thu Feb 7 07:59:36 2008// +/swank.asd/1.5/Thu Oct 11 14:10:25 2007// +/swank.lisp/1.527/Thu Feb 7 08:07:31 2008// +/test-all.sh/1.2/Thu Oct 11 14:10:25 2007// +/test.sh/1.9/Thu Oct 11 14:10:25 2007// +/xref.lisp/1.2/Thu Oct 11 14:10:25 2007// Modified: branches/trunk-reorg/thirdparty/slime/ChangeLog ============================================================================== --- branches/trunk-reorg/thirdparty/slime/ChangeLog (original) +++ branches/trunk-reorg/thirdparty/slime/ChangeLog Thu Feb 7 03:32:58 2008 @@ -1,7 +1,73 @@ +2008-02-05 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-search-buffer-package): Ask the lisp to read the + in-package form so that we properly deal with #+foo and |WHATEVER| + package names. + (slime-repl-set-package): Only prompt with a default package if + the repl's package is different from the current package. + +2008-02-04 Marco Baringer <mb(a)bese.it> + + * swank-openmcl.lisp (ccl::advise ccl::break): advise the + lower-level ccl::cbreak-loop instead of cl:break. + (frame-locals): If the value is a value-cell (a closed over value) + show the closed over value and not the value cell. + (disassemble-frame): add in x86-64 code. + + * slime-autoloads.el (slime-setup-contribs): Add contribs + directory to load-path. + + * slime.el (slime-setup): Add contribs directory to load-path. + + * swank-abcl.lisp, swank-allegro.lisp, swank-backend.lisp, + swank-clisp.lisp, swank-cmucl.lisp, swank-corman.lisp, + swank-ecl.lisp, swank-lispworks.lisp, swank-openmcl.lisp, + swank-sbcl.lisp, swank-scl.lisp, swank.lisp, + contrib/swank-fancy-inspector.lisp: Remove second argument from + swank:inspect-for-emacs. This functionality, choosing an inspector + at runtime, was never actually used and is, now, needless + complexity. + +2008-02-04 Helmut Eller <heller(a)common-lisp.net> + + Simpler code to bind 0-9 in the debugger. + + * slime.el (sldb-mode-map): When binding the keys 0-9, use eval + instead of two macros. + +2008-02-04 Helmut Eller <heller(a)common-lisp.net> + + Move some functions to swank-arglist.lisp. + + * swank.lisp (length=, ensure-list, recursively-empty-p) + (maybecall, exactly-one-p, read-softly-from-string) + (unintern-in-home-package, valid-function-name-p): Moved to + contrib/swank-arglist.lisp. + +2008-02-03 Marco Baringer <mb(a)bese.it> + + * swank.lisp (*sldb-condition-printer*): New variable. + (safe-condition-message): Use the current binding + of *sldb-condition-printer* to print the condition to a string. + + * slime.el (sldb-invoke-restart-by-name): New function. Invokes a + restart by name, uses completion to read restart's name. + (slime-define-keys sldb-mode-map): Bind + sldb-invoke-restart-by-name to I in sldb buffers. + + * swank-loader.lisp: When loading swank delete all swank packages + first. This protects the lisp from broken reloads of swank. Leave + the swank-loader package so that users can set *fasl-directory* + and *source-directory* as per the documentation. + (lisp-version-string): On openmcl use the full + cl:lisp-implementation-version, ccl::*openmcl-major-version* and + ccl::*openmcl-minor-version* aren't sufficently precise to notice + changes in openmcl's cvs. + 2008-01-27 Helmut Eller <heller(a)common-lisp.net> Make it easier to start a non-default Lisp from ELisp code. - + * slime.el (slime): If the argument is a symbol start the corresponding entry in slime-lisp-implementations. Typical use is something like: @@ -15,7 +81,7 @@ (suppress-sharp-dot): unused, delete it. * slime.el (test compile-defun): test with #+#.'(:and). - + 2008-01-21 Helmut Eller <heller(a)common-lisp.net> * slime.el (sldb-mode): Don't throw to toplevel in the Modified: branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries Thu Feb 7 03:32:58 2008 @@ -1,33 +1,37 @@ -/ChangeLog/1.82/Sun Jan 27 22:03:21 2008// -/README/1.3/Sun Jan 27 22:03:21 2008// -/bridge.el/1.1/Sun Jan 27 22:03:22 2008// -/inferior-slime.el/1.2/Sun Jan 27 22:03:22 2008// -/slime-asdf.el/1.3/Sun Jan 27 22:03:22 2008// -/slime-autodoc.el/1.7/Sun Jan 27 22:03:22 2008// -/slime-banner.el/1.4/Sun Jan 27 22:03:22 2008// -/slime-c-p-c.el/1.8/Sun Jan 27 22:03:22 2008// -/slime-editing-commands.el/1.6/Sun Jan 27 22:03:22 2008// -/slime-fancy-inspector.el/1.2/Sun Jan 27 22:03:22 2008// -/slime-fancy.el/1.4/Sun Jan 27 22:03:22 2008// -/slime-fuzzy.el/1.6/Sun Jan 27 22:03:22 2008// -/slime-highlight-edits.el/1.3/Sun Jan 27 22:03:22 2008// -/slime-parse.el/1.10/Sun Jan 27 22:03:22 2008// -/slime-presentation-streams.el/1.2/Sun Jan 27 22:03:22 2008// -/slime-presentations.el/1.12/Sun Jan 27 22:03:22 2008// -/slime-references.el/1.4/Sun Jan 27 22:03:22 2008// -/slime-scheme.el/1.1/Wed Jan 9 18:30:26 2008// -/slime-scratch.el/1.4/Sun Jan 27 22:03:22 2008// -/slime-tramp.el/1.2/Sun Jan 27 22:03:22 2008// -/slime-typeout-frame.el/1.6/Sun Jan 27 22:03:22 2008// -/slime-xref-browser.el/1.1/Sun Jan 27 22:03:22 2008// -/swank-arglists.lisp/1.18/Sun Jan 27 22:03:22 2008// -/swank-asdf.lisp/1.1/Sun Jan 27 22:03:22 2008// -/swank-c-p-c.lisp/1.2/Sun Jan 27 22:03:22 2008// -/swank-fancy-inspector.lisp/1.5/Sun Jan 27 22:03:22 2008// -/swank-fuzzy.lisp/1.7/Sun Jan 27 22:03:22 2008// -/swank-goo.goo/1.1/Sat Jan 19 14:08:27 2008// -/swank-kawa.scm/1.1/Sat Jan 19 14:08:27 2008// -/swank-listener-hooks.lisp/1.1/Sun Jan 27 22:03:22 2008// -/swank-presentation-streams.lisp/1.4/Sun Jan 27 22:03:22 2008// -/swank-presentations.lisp/1.4/Sun Jan 27 22:03:22 2008// +/ChangeLog/1.87/Thu Feb 7 08:07:31 2008// +/README/1.3/Thu Oct 11 14:10:25 2007// +/bridge.el/1.1/Thu Oct 11 14:10:25 2007// +/inferior-slime.el/1.2/Thu Oct 11 14:10:25 2007// +/slime-asdf.el/1.3/Thu Oct 11 14:10:25 2007// +/slime-autodoc.el/1.7/Thu Feb 7 07:59:35 2008// +/slime-banner.el/1.4/Thu Oct 11 14:10:25 2007// +/slime-c-p-c.el/1.8/Thu Oct 11 14:10:25 2007// +/slime-editing-commands.el/1.6/Thu Feb 7 07:59:35 2008// +/slime-fancy-inspector.el/1.2/Thu Oct 11 14:10:25 2007// +/slime-fancy.el/1.4/Thu Oct 11 14:10:25 2007// +/slime-fuzzy.el/1.6/Thu Feb 7 07:59:35 2008// +/slime-highlight-edits.el/1.3/Thu Oct 11 14:10:25 2007// +/slime-indentation.el/1.1/Sun Feb 3 18:45:14 2008// +/slime-motd.el/1.1/Sun Feb 3 18:39:23 2008// +/slime-parse.el/1.10/Thu Feb 7 07:59:35 2008// +/slime-presentation-streams.el/1.2/Thu Oct 11 14:10:25 2007// +/slime-presentations.el/1.12/Thu Feb 7 07:59:35 2008// +/slime-references.el/1.4/Thu Oct 11 14:10:25 2007// +/slime-scheme.el/1.1/Thu Feb 7 08:07:31 2008// +/slime-scratch.el/1.4/Thu Oct 11 14:10:25 2007// +/slime-tramp.el/1.2/Thu Oct 11 14:10:25 2007// +/slime-typeout-frame.el/1.6/Thu Feb 7 07:59:35 2008// +/slime-xref-browser.el/1.1/Thu Oct 11 14:10:25 2007// +/swank-arglists.lisp/1.20/Thu Feb 7 08:07:31 2008// +/swank-asdf.lisp/1.1/Thu Oct 11 14:10:25 2007// +/swank-c-p-c.lisp/1.2/Thu Oct 11 14:10:25 2007// +/swank-fancy-inspector.lisp/1.7/Thu Feb 7 08:07:32 2008// +/swank-fuzzy.lisp/1.7/Thu Feb 7 07:59:35 2008// +/swank-goo.goo/1.1/Thu Feb 7 08:07:32 2008// +/swank-indentation.lisp/1.1/Sun Feb 3 18:45:14 2008// +/swank-kawa.scm/1.1/Thu Feb 7 08:07:32 2008// +/swank-listener-hooks.lisp/1.1/Thu Oct 11 14:10:25 2007// +/swank-motd.lisp/1.1/Sun Feb 3 18:39:23 2008// +/swank-presentation-streams.lisp/1.5/Thu Feb 7 08:07:32 2008// +/swank-presentations.lisp/1.4/Thu Oct 11 14:10:25 2007// D Modified: branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog Thu Feb 7 03:32:58 2008 @@ -1,7 +1,37 @@ +2008-02-04 Marco Baringer <mb(a)bese.it> + + * swank-presentation-streams.lisp (presenting-object-1): Add + declare special *record-repl-results* to silence compiler + warnings. + + * swank-arglists.lisp (arglist-dispatch): Specialize operator-type + so openmcl doesn't warn about unused arguments. + (arglist-dispatch): add declare ignore form. + +2008-02-04 Helmut Eller <heller(a)common-lisp.net> + + Move some functions to swank-arglist.lisp. + + * swank-arglist.lisp (length=, ensure-list, recursively-empty-p) + (maybecall, exactly-one-p, read-softly-from-string) + (unintern-in-home-package, valid-function-name-p): Moved from + swank.lisp. to contrib/swank-arglist.lisp. + +2008-02-03 Marco Baringer <mb(a)bese.it> + + * swank-motd.lisp, slime-motd.el: Message Of The Day printing for + slime. + + * slime-indentation.el: Integrate cl-indent.el into slime's + contrib infrastructure. Fix bug in &rest. + + * swank-indentation.lisp: Allow an application runnig under slime + to update emacs' indentation notes. + 2008-01-27 Helmut Eller <heller(a)common-lisp.net> Make autodoc use the correct width of the typeout-window. - + * slime-autodoc.el (slime-autodoc-dimensions-function): New variable. (slime-autodoc-message-dimensions): Use it. @@ -13,7 +43,7 @@ 2008-01-27 Helmut Eller <heller(a)common-lisp.net> Use slime-require instead of a connected-hook. - + * slime-autodoc.el (slime-autodoc-on-connect): Deleted. 2008-01-20 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> Modified: branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp Thu Feb 7 03:32:58 2008 @@ -12,6 +12,40 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (swank-require :swank-c-p-c)) +(defun length= (seq n) + "Test for whether SEQ contains N number of elements. I.e. it's equivalent + to (= (LENGTH SEQ) N), but besides being more concise, it may also be more + efficiently implemented." + (etypecase seq + (list (do ((i n (1- i)) + (list seq (cdr list))) + ((or (<= i 0) (null list)) + (and (zerop i) (null list))))) + (sequence (= (length seq) n)))) + +(defun ensure-list (thing) + (if (listp thing) thing (list thing))) + +(defun recursively-empty-p (list) + "Returns whether LIST consists only of arbitrarily nested empty lists." + (cond ((not (listp list)) nil) + ((null list) t) + (t (every #'recursively-empty-p list)))) + +(defun maybecall (bool fn &rest args) + "Call FN with ARGS if BOOL is T. Otherwise return ARGS as multiple values." + (if bool (apply fn args) (values-list args))) + +(defun exactly-one-p (&rest values) + "If exactly one value in VALUES is non-NIL, this value is returned. +Otherwise NIL is returned." + (let ((found nil)) + (dolist (v values) + (when v (if found + (return-from exactly-one-p nil) + (setq found v)))) + found)) + (defun valid-operator-symbol-p (symbol) "Is SYMBOL the name of a function, a macro, or a special-operator?" (or (fboundp symbol) @@ -24,6 +58,14 @@ (let ((symbol (parse-symbol string))) (valid-operator-symbol-p symbol))) +(defun valid-function-name-p (form) + (or (symbolp form) + (and (consp form) + (second form) + (not (third form)) + (eq (first form) 'setf) + (symbolp (second form))))) + (defslimefun arglist-for-echo-area (raw-specs &key arg-indices print-right-margin print-lines) "Return the arglist for the first valid ``form spec'' in @@ -243,6 +285,29 @@ (assert (= pos (length string))) (values sexp interned?))) +(defun read-softly-from-string (string) + "Returns three values: + + 1. the object resulting from READing STRING. + + 2. The index of the first character in STRING that was not read. + + 3. T if the object is a symbol that had to be newly interned + in some package. (This does not work for symbols in + compound forms like lists or vectors.)" + (multiple-value-bind (symbol found? symbol-name package) (parse-symbol string) + (if found? + (values symbol (length string) nil) + (multiple-value-bind (sexp pos) (read-from-string string) + (values sexp pos + (when (symbolp sexp) + (prog1 t + ;; assert that PARSE-SYMBOL didn't parse incorrectly. + (assert (and (equal symbol-name (symbol-name sexp)) + (eq package (symbol-package sexp))))))))))) + +(defun unintern-in-home-package (symbol) + (unintern symbol (symbol-package symbol))) (defstruct (arglist (:conc-name arglist.) (:predicate arglist-p)) provided-args ; list of the provided actual arguments @@ -1022,7 +1087,7 @@ (defgeneric arglist-dispatch (operator-type operator arguments &key remove-args)) -(defmethod arglist-dispatch (operator-type operator arguments &key (remove-args t)) +(defmethod arglist-dispatch ((operator-type t) operator arguments &key (remove-args t)) (when (and (symbolp operator) (valid-operator-symbol-p operator)) (multiple-value-bind (decoded-arglist determining-args any-enrichment) @@ -1075,7 +1140,7 @@ (defmethod arglist-dispatch ((operator-type (eql :function)) (operator (eql 'declare)) arguments &key (remove-args t)) ;; Catching 'DECLARE before SWANK-BACKEND:ARGLIST can barf. - (declare (ignore remove-args)) + (declare (ignore remove-args arguments)) (make-arglist :rest '#:decl-specifiers)) (defmethod arglist-dispatch ((operator-type (eql :declaration)) Modified: branches/trunk-reorg/thirdparty/slime/contrib/swank-fancy-inspector.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/swank-fancy-inspector.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/swank-fancy-inspector.lisp Thu Feb 7 03:32:58 2008 @@ -6,12 +6,7 @@ (in-package :swank) -;; Subclass `backend-inspector' so that backend specific methods are -;; also considered. -(defclass fancy-inspector (backend-inspector) ()) - -(defmethod inspect-for-emacs ((symbol symbol) (inspector fancy-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((symbol symbol)) (let ((package (symbol-package symbol))) (multiple-value-bind (_symbol status) (and package (find-symbol (string symbol) package)) @@ -94,8 +89,7 @@ (t (list label ": " '(:newline) " " docstring '(:newline)))))) -(defmethod inspect-for-emacs ((f function) inspector) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((f function)) (values "A function." (append (label-value-line "Name" (function-name f)) @@ -128,12 +122,11 @@ (swank-mop:method-qualifiers method) (method-specializers-for-inspect method))) -(defmethod inspect-for-emacs ((object standard-object) - (inspector fancy-inspector)) +(defmethod inspect-for-emacs ((object standard-object)) (let ((class (class-of object))) (values "An object." `("Class: " (:value ,class) (:newline) - ,@(all-slots-for-inspector object inspector))))) + ,@(all-slots-for-inspector object))))) (defvar *gf-method-getter* 'methods-by-applicability "This function is called to get the methods of a generic function. @@ -193,8 +186,8 @@ `(" " (:action "[make unbound]" ,(lambda () (swank-mop:slot-makunbound-using-class class object slot))))))))) -(defgeneric all-slots-for-inspector (object inspector) - (:method ((object standard-object) inspector) +(defgeneric all-slots-for-inspector (object) + (:method ((object standard-object)) (declare (ignore inspector)) (append '("--------------------" (:newline) "All Slots:" (:newline)) @@ -231,8 +224,7 @@ append slot-presentation collect '(:newline)))))) -(defmethod inspect-for-emacs ((gf standard-generic-function) - (inspector fancy-inspector)) +(defmethod inspect-for-emacs ((gf standard-generic-function)) (flet ((lv (label value) (label-value-line label value))) (values "A generic function." @@ -255,10 +247,9 @@ (remove-method gf m)))) (:newline))) `((:newline)) - (all-slots-for-inspector gf inspector))))) + (all-slots-for-inspector gf))))) -(defmethod inspect-for-emacs ((method standard-method) - (inspector fancy-inspector)) +(defmethod inspect-for-emacs ((method standard-method)) (values "A method." `("Method defined on the generic function " (:value ,(swank-mop:method-generic-function method) @@ -276,10 +267,9 @@ (:newline) "Method function: " (:value ,(swank-mop:method-function method)) (:newline) - ,@(all-slots-for-inspector method inspector)))) + ,@(all-slots-for-inspector method)))) -(defmethod inspect-for-emacs ((class standard-class) - (inspector fancy-inspector)) +(defmethod inspect-for-emacs ((class standard-class)) (values "A class." `("Name: " (:value ,(class-name class)) (:newline) @@ -336,10 +326,9 @@ `(:value ,(swank-mop:class-prototype class)) '"#<N/A (class not finalized)>") (:newline) - ,@(all-slots-for-inspector class inspector)))) + ,@(all-slots-for-inspector class)))) -(defmethod inspect-for-emacs ((slot swank-mop:standard-slot-definition) - (inspector fancy-inspector)) +(defmethod inspect-for-emacs ((slot swank-mop:standard-slot-definition)) (values "A slot." `("Name: " (:value ,(swank-mop:slot-definition-name slot)) (:newline) @@ -353,7 +342,7 @@ "#<unspecified>") (:newline) "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot)) (:newline) - ,@(all-slots-for-inspector slot inspector)))) + ,@(all-slots-for-inspector slot)))) ;; Wrapper structure over the list of symbols of a package that should @@ -445,9 +434,7 @@ (:newline) ))))) -(defmethod inspect-for-emacs ((%container %package-symbols-container) - (inspector fancy-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((%container %package-symbols-container)) (with-struct (%container. title description symbols grouping-kind) %container (values title `(,@description @@ -464,10 +451,7 @@ (:newline) (:newline) ,@(make-symbols-listing grouping-kind symbols))))) - -(defmethod inspect-for-emacs ((package package) - (inspector fancy-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((package package)) (let ((package-name (package-name package)) (package-nicknames (package-nicknames package)) (package-use-list (package-use-list package)) @@ -561,9 +545,7 @@ :description nil))))))) -(defmethod inspect-for-emacs ((pathname pathname) - (inspector fancy-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((pathname pathname)) (values (if (wild-pathname-p pathname) "A wild pathname." "A pathname.") @@ -579,9 +561,7 @@ (not (probe-file pathname))) (label-value-line "Truename" (truename pathname)))))) -(defmethod inspect-for-emacs ((pathname logical-pathname) - (inspector fancy-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((pathname logical-pathname)) (values "A logical pathname." (append (label-value-line* @@ -601,9 +581,7 @@ ("Truename" (if (not (wild-pathname-p pathname)) (probe-file pathname))))))) -(defmethod inspect-for-emacs ((n number) - (inspector fancy-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((n number)) (values "A number." `("Value: " ,(princ-to-string n)))) (defun format-iso8601-time (time-value &optional include-timezone-p) @@ -626,9 +604,7 @@ year month day hour minute second include-timezone-p (format-iso8601-timezone zone))))) -(defmethod inspect-for-emacs ((i integer) - (inspector fancy-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((i integer)) (values "A number." (append `(,(format nil "Value: ~D = #x~8,'0X = #o~O = #b~,,' ,8:B~@[ = ~E~]" @@ -640,26 +616,20 @@ (ignore-errors (label-value-line "Universal-time" (format-iso8601-time i t)))))) -(defmethod inspect-for-emacs ((c complex) - (inspector fancy-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((c complex)) (values "A complex number." (label-value-line* ("Real part" (realpart c)) ("Imaginary part" (imagpart c))))) -(defmethod inspect-for-emacs ((r ratio) - (inspector fancy-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((r ratio)) (values "A non-integer ratio." (label-value-line* ("Numerator" (numerator r)) ("Denominator" (denominator r)) ("As float" (float r))))) -(defmethod inspect-for-emacs ((f float) - (inspector fancy-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((f float)) (values "A floating point number." (cond ((> f most-positive-long-float) @@ -679,9 +649,7 @@ (label-value-line "Digits" (float-digits f)) (label-value-line "Precision" (float-precision f)))))))) -(defmethod inspect-for-emacs ((stream file-stream) - (inspector fancy-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((stream file-stream)) (multiple-value-bind (title content) (call-next-method) (declare (ignore title)) @@ -699,9 +667,7 @@ (:newline)) content)))) -(defmethod inspect-for-emacs ((condition stream-error) - (inspector fancy-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((condition stream-error)) (multiple-value-bind (title content) (call-next-method) (let ((stream (stream-error-stream condition))) @@ -724,14 +690,10 @@ (defvar *fancy-inpector-undo-list* nil) (defslimefun fancy-inspector-init () - (let ((i *default-inspector*)) - (push (lambda () (setq *default-inspector* i)) - *fancy-inpector-undo-list*)) - (setq *default-inspector* (make-instance 'fancy-inspector)) t) (defslimefun fancy-inspector-unload () (loop while *fancy-inpector-undo-list* do (funcall (pop *fancy-inpector-undo-list*)))) -(provide :swank-fancy-inspector) \ No newline at end of file +(provide :swank-fancy-inspector) Modified: branches/trunk-reorg/thirdparty/slime/contrib/swank-presentation-streams.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/swank-presentation-streams.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/swank-presentation-streams.lisp Thu Feb 7 03:32:58 2008 @@ -210,6 +210,9 @@ (defun presenting-object-1 (object stream continue) "Uses the bridge mechanism with two messages >id and <id. The first one says that I am starting to print an object with this id. The second says I am finished" + ;; this declare special is to let the compiler know that *record-repl-results* will eventually be + ;; a global special, even if it isn't when this file is compiled/loaded. + (declare (special *record-repl-results*)) (let ((slime-stream-p (and *record-repl-results* (slime-stream-p stream)))) (if slime-stream-p Modified: branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries ============================================================================== --- branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries (original) +++ branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries Thu Feb 7 03:32:58 2008 @@ -1,9 +1,9 @@ -/.cvsignore/1.1/Mon Jul 24 14:13:23 2006// -/Makefile/1.12/Sun Jan 27 22:03:22 2008// -/slime-refcard.pdf/1.1/Sun Jan 27 22:03:22 2008// -/slime-refcard.tex/1.1/Sun Jan 27 22:03:22 2008// -/slime-small.eps/1.1/Sun Jan 27 22:03:22 2008// -/slime-small.pdf/1.1/Sun Jan 27 22:03:22 2008// -/slime.texi/1.64/Sun Jan 27 22:03:22 2008// -/texinfo-tabulate.awk/1.2/Sun Jan 27 22:03:22 2008// +/.cvsignore/1.1/Thu Oct 11 14:10:24 2007// +/Makefile/1.12/Thu Oct 11 14:10:24 2007// +/slime-refcard.pdf/1.1/Thu Oct 11 14:10:24 2007// +/slime-refcard.tex/1.1/Thu Oct 11 14:10:24 2007// +/slime-small.eps/1.1/Thu Oct 11 14:10:24 2007// +/slime-small.pdf/1.1/Thu Oct 11 14:10:24 2007// +/slime.texi/1.64/Thu Feb 7 07:59:33 2008// +/texinfo-tabulate.awk/1.2/Thu Oct 11 14:10:24 2007// D Modified: branches/trunk-reorg/thirdparty/slime/slime-autoloads.el ============================================================================== --- branches/trunk-reorg/thirdparty/slime/slime-autoloads.el (original) +++ branches/trunk-reorg/thirdparty/slime/slime-autoloads.el Thu Feb 7 03:32:58 2008 @@ -39,11 +39,16 @@ (defvar slime-setup-contribs nil) (defun slime-setup-contribs () - (dolist (c slime-setup-contribs) - (require c) - (let ((init (intern (format "%s-init" c)))) - (when (fboundp init) - (funcall init))))) + (when slime-setup-contribs + (pushnew (file-name-as-directory + (expand-file-name (concat slime-path "contribs"))) + load-path + :test 'string=) + (dolist (c slime-setup-contribs) + (require c) + (let ((init (intern (format "%s-init" c)))) + (when (fboundp init) + (funcall init)))))) (provide 'slime-autoloads) Modified: branches/trunk-reorg/thirdparty/slime/slime.el ============================================================================== --- branches/trunk-reorg/thirdparty/slime/slime.el (original) +++ branches/trunk-reorg/thirdparty/slime/slime.el Thu Feb 7 03:32:58 2008 @@ -71,11 +71,16 @@ CONTRIBS is a list of contrib packages to load." (when (member 'lisp-mode slime-lisp-modes) (add-hook 'lisp-mode-hook 'slime-lisp-mode-hook)) - (dolist (c contribs) - (require c) - (let ((init (intern (format "%s-init" c)))) - (when (fboundp init) - (funcall init))))) + (when contribs + (pushnew (file-name-as-directory + (expand-file-name (concat slime-path "contribs"))) + load-path + :test 'string=) + (dolist (c contribs) + (require c) + (let ((init (intern (format "%s-init" c)))) + (when (fboundp init) + (funcall init)))))) (defun slime-lisp-mode-hook () (slime-mode 1) @@ -2262,7 +2267,11 @@ (save-excursion (when (or (re-search-backward regexp nil t) (re-search-forward regexp nil t)) - (match-string-no-properties 2))))) + ;; package name can be a string designator, convert it to a string. + ;;(slime-eval `(cl:string (cl:second (cl:read-from-string ,(match-string-no-properties 0)))) + ;; "COMMON-LISP-USER") + (match-string-no-properties 2) + )))) ;;; Synchronous requests are implemented in terms of asynchronous ;;; ones. We make an asynchronous request with a continuation function @@ -3312,8 +3321,12 @@ (defun slime-repl-set-package (package) "Set the package of the REPL buffer to PACKAGE." - (interactive (list (slime-read-package-name - "Package: " (slime-pretty-find-buffer-package)))) + (interactive (list (slime-read-package-name "Package: " + (if (string= (slime-current-package) + (with-current-buffer (slime-repl-buffer) + (slime-current-package))) + nil + (slime-pretty-find-buffer-package))))) (with-current-buffer (slime-output-buffer) (let ((unfinished-input (slime-repl-current-input))) (destructuring-bind (name prompt-string) @@ -6551,6 +6564,7 @@ (">" 'sldb-end-of-backtrace) ("t" 'sldb-toggle-details) ("r" 'sldb-restart-frame) + ("I" 'sldb-invoke-restart-by-name) ("R" 'sldb-return-from-frame) ("c" 'sldb-continue) ("s" 'sldb-step) @@ -6573,23 +6587,14 @@ (define-key sldb-mode-map key command))))) ;; Keys 0-9 are shortcuts to invoke particular restarts. -(defmacro define-sldb-invoke-restart-key (number key) +(dotimes (number 10) (let ((fname (intern (format "sldb-invoke-restart-%S" number))) (docstring (format "Invoke restart numbered %S." number))) - `(progn - (defun ,fname () - ,docstring - (interactive) - (sldb-invoke-restart ,number)) - (define-key sldb-mode-map ,key ',fname)))) - -(defmacro define-sldb-invoke-restart-keys (from to) - `(progn - ,@(loop for n from from to to - collect `(define-sldb-invoke-restart-key ,n - ,(number-to-string n))))) - -(define-sldb-invoke-restart-keys 0 9) + (eval `(defun ,fname () + ,docstring + (interactive) + (sldb-invoke-restart ,number))) + (define-key sldb-mode-map (number-to-string number) fname))) ;;;;; SLDB buffer creation & update @@ -7223,6 +7228,14 @@ ((:ok value) (message "Restart returned: %s" value)) ((:abort))))) +(defun sldb-invoke-restart-by-name (restart-name) + (interactive (list (completing-read "Restart: " + sldb-restarts nil t + "" + 'sldb-invoke-restart-by-name))) + (sldb-invoke-restart (position restart-name sldb-restarts + :test 'string= :key 'first))) + (defun sldb-break-with-default-debugger () "Enter default debugger." (interactive) Modified: branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp Thu Feb 7 03:32:58 2008 @@ -421,14 +421,7 @@ ;;;; Inspecting -(defclass abcl-inspector (backend-inspector) ()) - -(defimplementation make-default-inspector () - (make-instance 'abcl-inspector)) - -(defmethod inspect-for-emacs ((slot mop::slot-definition) - (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((slot mop::slot-definition)) (values "A slot." `("Name: " (:value ,(mop::%slot-definition-name slot)) (:newline) @@ -443,8 +436,7 @@ " Function: " (:value ,(mop::%slot-definition-initfunction slot)) (:newline)))) -(defmethod inspect-for-emacs ((f function) (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((f function)) (values "A function." `(,@(when (function-name f) `("Name: " @@ -461,7 +453,7 @@ #| -(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) +(defmethod inspect-for-emacs ((o t)) (let* ((class (class-of o)) (slots (mop::class-slots class))) (values (format nil "~A~% is a ~A" o class) Modified: branches/trunk-reorg/thirdparty/slime/swank-allegro.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-allegro.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank-allegro.lisp Thu Feb 7 03:32:58 2008 @@ -564,13 +564,7 @@ ;;;; Inspecting -(defclass acl-inspector (backend-inspector) ()) - -(defimplementation make-default-inspector () - (make-instance 'acl-inspector)) - -(defmethod inspect-for-emacs ((f function) inspector) - inspector +(defmethod inspect-for-emacs ((f function)) (values "A function." (append (label-value-line "Name" (function-name f)) @@ -579,17 +573,13 @@ (when doc `("Documentation:" (:newline) ,doc)))))) -(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) - inspector +(defmethod inspect-for-emacs ((o t)) (values "A value." (allegro-inspect o))) -(defmethod inspect-for-emacs ((o function) (inspector backend-inspector)) - inspector +(defmethod inspect-for-emacs ((o function)) (values "A function." (allegro-inspect o))) -(defmethod inspect-for-emacs ((o standard-object) - (inspector backend-inspector)) - inspector +(defmethod inspect-for-emacs ((o standard-object)) (values (format nil "~A is a standard-object." o) (allegro-inspect o))) (defun allegro-inspect (o) Modified: branches/trunk-reorg/thirdparty/slime/swank-backend.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-backend.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank-backend.lisp Thu Feb 7 03:32:58 2008 @@ -840,26 +840,10 @@ ;;;; Inspector -(defclass inspector () - () - (:documentation "Super class of inspector objects. - -Implementations should sub class in order to dispatch off of the -inspect-for-emacs method.")) - -(defclass backend-inspector (inspector) ()) - -(definterface make-default-inspector () - "Return an inspector object suitable for passing to inspect-for-emacs.") - -(defgeneric inspect-for-emacs (object inspector) +(defgeneric inspect-for-emacs (object) (:documentation "Explain to Emacs how to inspect OBJECT. -The argument INSPECTOR is an object representing how to get at -the internals of OBJECT, it is usually an implementation specific -class used simply for dispatching to the proper method. - Returns two values: a string which will be used as the title of the inspector buffer and a list specifying how to render the object for inspection. @@ -880,12 +864,11 @@ NIL - do nothing.")) -(defmethod inspect-for-emacs ((object t) (inspector t)) +(defmethod inspect-for-emacs ((object t)) "Generic method for inspecting any kind of object. Since we don't know how to deal with OBJECT we simply dump the output of CL:DESCRIBE." - (declare (ignore inspector)) (values "A value." `("Type: " (:value ,(type-of object)) (:newline) Modified: branches/trunk-reorg/thirdparty/slime/swank-clisp.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-clisp.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank-clisp.lisp Thu Feb 7 03:32:58 2008 @@ -627,12 +627,7 @@ ;;;; Inspecting -(defclass clisp-inspector (backend-inspector) ()) - -(defimplementation make-default-inspector () (make-instance 'clisp-inspector)) - -(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((o t)) (let* ((*print-array* nil) (*print-pretty* t) (*print-circle* t) (*print-escape* t) (*print-lines* custom:*inspect-print-lines*) Modified: branches/trunk-reorg/thirdparty/slime/swank-cmucl.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-cmucl.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank-cmucl.lisp Thu Feb 7 03:32:58 2008 @@ -1869,7 +1869,7 @@ :key #'symbol-value))) (format t ", type: ~A" type-symbol)))))) -(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) +(defmethod inspect-for-emacs ((o t)) (cond ((di::indirect-value-cell-p o) (values (format nil "~A is a value cell." o) `("Value: " (:value ,(c:value-cell-ref o))))) @@ -1887,8 +1887,7 @@ (loop for value in parts for i from 0 append (label-value-line i value)))))) -(defmethod inspect-for-emacs ((o function) (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((o function)) (let ((header (kernel:get-type o))) (cond ((= header vm:function-header-type) (values (format nil "~A is a function." o) @@ -1915,9 +1914,7 @@ (t (call-next-method))))) -(defmethod inspect-for-emacs ((o kernel:funcallable-instance) - (i backend-inspector)) - (declare (ignore i)) +(defmethod inspect-for-emacs ((o kernel:funcallable-instance)) (values (format nil "~A is a funcallable-instance." o) (append (label-value-line* @@ -1926,8 +1923,7 @@ (:layout (kernel:%funcallable-instance-layout o))) (nth-value 1 (cmucl-inspect o))))) -(defmethod inspect-for-emacs ((o kernel:code-component) (_ backend-inspector)) - (declare (ignore _)) +(defmethod inspect-for-emacs ((o kernel:code-component)) (values (format nil "~A is a code data-block." o) (append (label-value-line* @@ -1954,8 +1950,7 @@ (ash (kernel:%code-code-size o) vm:word-shift) :stream s)))))))) -(defmethod inspect-for-emacs ((o kernel:fdefn) (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((o kernel:fdefn)) (values (format nil "~A is a fdenf object." o) (label-value-line* ("name" (kernel:fdefn-name o)) @@ -1964,8 +1959,7 @@ (sys:int-sap (kernel:get-lisp-obj-address o)) (* vm:fdefn-raw-addr-slot vm:word-bytes)))))) -(defmethod inspect-for-emacs ((o array) (inspector backend-inspector)) - inspector +(defmethod inspect-for-emacs ((o array)) (if (typep o 'simple-array) (call-next-method) (values (format nil "~A is an array." o) @@ -1980,8 +1974,7 @@ (:displaced-p (kernel:%array-displaced-p o)) (:dimensions (array-dimensions o)))))) -(defmethod inspect-for-emacs ((o simple-vector) (inspector backend-inspector)) - inspector +(defmethod inspect-for-emacs ((o simple-vector)) (values (format nil "~A is a simple-vector." o) (append (label-value-line* Modified: branches/trunk-reorg/thirdparty/slime/swank-corman.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-corman.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank-corman.lisp Thu Feb 7 03:32:58 2008 @@ -387,21 +387,13 @@ ;; Hack to make swank.lisp load, at least (defclass file-stream ()) -(defclass corman-inspector (backend-inspector) - ()) - -(defimplementation make-default-inspector () - (make-instance 'corman-inspector)) - (defun comma-separated (list &optional (callback (lambda (v) `(:value ,v)))) (butlast (loop for e in list collect (funcall callback e) collect ", "))) -(defmethod inspect-for-emacs ((class standard-class) - (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((class standard-class)) (values "A class." `("Name: " (:value ,(class-name class)) (:newline) @@ -438,9 +430,8 @@ '("#<N/A (class not finalized)>")) (:newline)))) -(defmethod inspect-for-emacs ((slot cons) (inspector backend-inspector)) +(defmethod inspect-for-emacs ((slot cons)) ;; Inspects slot definitions - (declare (ignore inspector)) (if (eq (car slot) :name) (values "A slot." `("Name: " (:value ,(swank-mop:slot-definition-name slot)) @@ -457,9 +448,7 @@ (:newline))) (call-next-method))) -(defmethod inspect-for-emacs ((pathname pathnames::pathname-internal) - inspector) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((pathname pathnames::pathname-internal)) (values (if (wild-pathname-p pathname) "A wild pathname." "A pathname.") @@ -475,7 +464,7 @@ (not (probe-file pathname))) (label-value-line "Truename" (truename pathname)))))) -(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) +(defmethod inspect-for-emacs ((o t)) (cond ((cl::structurep o) (inspect-structure o)) (t (call-next-method)))) Modified: branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp Thu Feb 7 03:32:58 2008 @@ -248,13 +248,7 @@ ;;;; Inspector -(defclass ecl-inspector (inspector) - ()) - -(defimplementation make-default-inspector () - (make-instance 'ecl-inspector)) - -(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) +(defmethod inspect-for-emacs ((o t)) ; ecl clos support leaves some to be desired (cond ((streamp o) Modified: branches/trunk-reorg/thirdparty/slime/swank-lispworks.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-lispworks.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank-lispworks.lisp Thu Feb 7 03:32:58 2008 @@ -629,20 +629,15 @@ (defimplementation make-default-inspector () (make-instance 'lispworks-inspector)) -(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((o t)) (lispworks-inspect o)) -(defmethod inspect-for-emacs ((o function) - (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((o function)) (lispworks-inspect o)) ;; FIXME: slot-boundp-using-class in LW works with names so we can't ;; use our method in swank.lisp. -(defmethod inspect-for-emacs ((o standard-object) - (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((o standard-object)) (lispworks-inspect o)) (defun lispworks-inspect (o) Modified: branches/trunk-reorg/thirdparty/slime/swank-loader.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-loader.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank-loader.lisp Thu Feb 7 03:32:58 2008 @@ -18,6 +18,12 @@ ;; (defparameter swank-loader::*fasl-directory* "/tmp/fasl/") ;; (load ".../swank-loader.lisp") +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (find-package :swank) + (delete-package :swank) + (delete-package :swank-io-package) + (delete-package :swank-backend))) + (cl:defpackage :swank-loader (:use :cl) (:export :load-swank @@ -60,14 +66,9 @@ :sparc64 :sparc :hppa64 :hppa)) (defun lisp-version-string () - #+cmu (substitute-if #\_ (lambda (x) (find x " /")) + #+(or openmcl cmu) (substitute-if #\_ (lambda (x) (find x " /")) (lisp-implementation-version)) - #+scl (lisp-implementation-version) - #+sbcl (lisp-implementation-version) - #+ecl (lisp-implementation-version) - #+openmcl (format nil "~d.~d" - ccl::*openmcl-major-version* - ccl::*openmcl-minor-version*) + #+(or cormanlisp scl sbcl ecl) (lisp-implementation-version) #+lispworks (lisp-implementation-version) #+allegro (format nil "~A~A~A" @@ -76,8 +77,7 @@ (if (member :64bit *features*) "-64bit" "")) #+clisp (let ((s (lisp-implementation-version))) (subseq s 0 (position #\space s))) - #+armedbear (lisp-implementation-version) - #+cormanlisp (lisp-implementation-version)) + #+armedbear (lisp-implementation-version)) (defun unique-directory-name () "Return a name that can be used as a directory name that is Modified: branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp Thu Feb 7 03:32:58 2008 @@ -211,14 +211,18 @@ (defvar *break-in-sldb* t) + (let ((ccl::*warn-if-redefine-kernel* nil)) - (ccl::advise - cl::break + (ccl::advise + ccl::cbreak-loop (if (and *break-in-sldb* - (find ccl::*current-process* (symbol-value (intern "*CONNECTIONS*" 'swank)) - :key (intern "CONNECTION.REPL-THREAD" 'swank))) + (find ccl::*current-process* + (symbol-value (intern (string :*connections*) :swank)) + :key (intern (string :connection.repl-thread) :swank))) (apply 'break-in-sldb ccl::arglist) - (:do-it)) :when :around :name sldb-break)) + (:do-it)) + :when :around + :name sldb-break)) (defun break-in-sldb (&optional string &rest args) (let ((c (make-condition 'simple-condition @@ -335,8 +339,7 @@ for (value nil name) = (multiple-value-list (ccl::nth-value-in-frame p count context lfun pc vsp parent-vsp)) when name do (incf varcount) until (= varcount var) - finally (return value)) - ))))))) + finally (return value))))))))) (defun xref-locations (relation name &optional (inverse nil)) (flet ((function-source-location (entry) @@ -345,8 +348,8 @@ (ccl::%db-key-from-xref-entry entry) (if (eql (ccl::xref-entry-type entry) 'macro) - 'function - (ccl::xref-entry-type entry))) + 'function + (ccl::xref-entry-type entry))) (cond ((not info) (list :error (format nil "No source info available for ~A" @@ -466,7 +469,8 @@ (setq ccl::*fasl-save-definitions* nil) (setq ccl::*fasl-save-doc-strings* t) (setq ccl::*fasl-save-local-symbols* t) - (setq ccl::*ppc2-compiler-register-save-label* t) + #+ppc (setq ccl::*ppc2-compiler-register-save-label* t) + #+x86-64 (setq ccl::*x862-compiler-register-save-label* t) (setq ccl::*save-arglist-info* t) (setq ccl::*save-definitions* nil) (setq ccl::*save-doc-strings* t) @@ -513,9 +517,8 @@ (defun frame-arguments (p context lfun pc) "Returns a string representing the arguments of a frame." - (multiple-value-bind (args types names count nclosed) + (multiple-value-bind (args types names) (ccl::frame-supplied-args p lfun pc nil context) - (declare (ignore count nclosed)) (let ((result nil)) (loop named loop for var = (cond @@ -575,7 +578,9 @@ (push (list :name name :id 0 - :value var) + :value (if (typep var 'ccl::value-cell) + (ccl::uvref var 0) + var)) result)))) (return-from frame-locals (nreverse result))))))))) @@ -610,19 +615,24 @@ (when (= frame-number the-frame-number) (setq function-to-disassemble lfun) (return-from find-frame))))) - (ccl::print-ppc-instructions - *standard-output* - (ccl::function-to-dll-header function-to-disassemble) nil))) + #+ppc (ccl::print-ppc-instructions + *standard-output* + (ccl::function-to-dll-header function-to-disassemble) + nil) + #+x86-64 (ccl::x8664-xdisassemble function-to-disassemble))) ;;; -(defun canonicalize-location (file symbol) +(defun canonicalize-location (file symbol &optional snippet) (etypecase file ((or string pathname) (multiple-value-bind (truename c) (ignore-errors (namestring (truename file))) (cond (c (list :error (princ-to-string c))) (t (make-location (list :file (remove-filename-quoting truename)) - (list :function-name (princ-to-string symbol))))))))) + (list :function-name (princ-to-string symbol)) + (if snippet + (list :snippet snippet) + '())))))))) (defun remove-filename-quoting (string) (if (search "\\" string) @@ -644,20 +654,20 @@ (list (list type symbol) (canonicalize-location file symbol)))))) - (defun function-source-location (function) - (multiple-value-bind (info name) (ccl::edit-definition-p function) + (multiple-value-bind (info name) + (ccl::edit-definition-p function) (cond ((not info) (list :error (format nil "No source info available for ~A" function))) ((typep (caar info) 'ccl::method) `(:location (:file ,(remove-filename-quoting (namestring (translate-logical-pathname (cdr (car info))) ))) (:method ,(princ-to-string (ccl::method-name (caar info))) - ,(mapcar 'princ-to-string - (mapcar #'specializer-name - (ccl::method-specializers (caar info)))) - ,@(mapcar 'princ-to-string (ccl::method-qualifiers (caar info)))) + ,(mapcar 'princ-to-string + (mapcar #'specializer-name + (ccl::method-specializers (caar info)))) + ,@(mapcar 'princ-to-string (ccl::method-qualifiers (caar info)))) nil)) - (t (canonicalize-location (cdr (first info)) name))))) + (t (canonicalize-location (second (first info)) name (third (first info))))))) (defimplementation frame-source-location-for-emacs (index) "Return to Emacs the location of the source code for the @@ -693,6 +703,7 @@ ,form))) ))))))) +#+ppc (defimplementation return-from-frame (index form) (let ((values (multiple-value-list (eval-in-frame form index)))) (map-backtrace @@ -700,7 +711,8 @@ (declare (ignore context lfun pc)) (when (= frame-number index) (ccl::apply-in-frame p #'values values)))))) - + +#+ppc (defimplementation restart-frame (index) (map-backtrace (lambda (frame-number p context lfun pc) @@ -784,19 +796,13 @@ ;;;; Inspection -(defclass openmcl-inspector (backend-inspector) ()) - -(defimplementation make-default-inspector () - (make-instance 'openmcl-inspector)) - (defimplementation describe-primitive-type (thing) (let ((typecode (ccl::typecode thing))) (if (gethash typecode *value2tag*) (string (gethash typecode *value2tag*)) (string (nth typecode '(tag-fixnum tag-list tag-misc tag-imm)))))) -(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((o t)) (let* ((i (inspector::make-inspector o)) (count (inspector::compute-line-count i)) (lines @@ -814,7 +820,7 @@ (pprint o s))) lines))) -(defmethod inspect-for-emacs :around ((o t) (inspector backend-inspector)) +(defmethod inspect-for-emacs :around ((o t)) (if (or (uvector-inspector-p o) (not (ccl:uvectorp o))) (call-next-method) @@ -834,8 +840,7 @@ (:method ((object t)) nil) (:method ((object uvector-inspector)) t)) -(defmethod inspect-for-emacs ((uv uvector-inspector) - (inspector backend-inspector)) +(defmethod inspect-for-emacs ((uv uvector-inspector)) (with-slots (object) uv (values (format nil "The UVECTOR for ~S." object) @@ -855,8 +860,7 @@ (cellp (ccl::closed-over-value-p value))) (list label (if cellp (ccl::closed-over-value value) value)))))) -(defmethod inspect-for-emacs ((c ccl::compiled-lexical-closure) (inspector t)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((c ccl::compiled-lexical-closure)) (values (format nil "A closure: ~a" c) `(,@(if (arglist c) Modified: branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp Thu Feb 7 03:32:58 2008 @@ -1001,13 +1001,7 @@ ;;;; Inspector -(defclass sbcl-inspector (backend-inspector) ()) - -(defimplementation make-default-inspector () - (make-instance 'sbcl-inspector)) - -(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((o t)) (cond ((sb-di::indirect-value-cell-p o) (values "A value cell." (label-value-line* (:value (sb-kernel:value-cell-ref o))))) @@ -1019,8 +1013,7 @@ (values text (loop for value in parts for i from 0 append (label-value-line i value)))))))) -(defmethod inspect-for-emacs ((o function) (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((o function)) (let ((header (sb-kernel:widetag-of o))) (cond ((= header sb-vm:simple-fun-header-widetag) (values "A simple-fun." @@ -1041,8 +1034,7 @@ i (sb-kernel:%closure-index-ref o i)))))) (t (call-next-method o))))) -(defmethod inspect-for-emacs ((o sb-kernel:code-component) (_ backend-inspector)) - (declare (ignore _)) +(defmethod inspect-for-emacs ((o sb-kernel:code-component)) (values (format nil "~A is a code data-block." o) (append (label-value-line* @@ -1070,22 +1062,18 @@ (ash (sb-kernel:%code-code-size o) sb-vm:word-shift) :stream s)))))))) -(defmethod inspect-for-emacs ((o sb-ext:weak-pointer) (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((o sb-ext:weak-pointer)) (values "A weak pointer." (label-value-line* (:value (sb-ext:weak-pointer-value o))))) -(defmethod inspect-for-emacs ((o sb-kernel:fdefn) (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((o sb-kernel:fdefn)) (values "A fdefn object." (label-value-line* (:name (sb-kernel:fdefn-name o)) (:function (sb-kernel:fdefn-fun o))))) -(defmethod inspect-for-emacs :around ((o generic-function) - (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs :around ((o generic-function)) (multiple-value-bind (title contents) (call-next-method) (values title (append Modified: branches/trunk-reorg/thirdparty/slime/swank-scl.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-scl.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank-scl.lisp Thu Feb 7 03:32:58 2008 @@ -1740,7 +1740,7 @@ :key #'symbol-value))) (format t ", type: ~A" type-symbol)))))) -(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) +(defmethod inspect-for-emacs ((o t)) (cond ((di::indirect-value-cell-p o) (values (format nil "~A is a value cell." o) `("Value: " (:value ,(c:value-cell-ref o))))) @@ -1759,8 +1759,7 @@ (loop for value in parts for i from 0 append (label-value-line i value)))))) -(defmethod inspect-for-emacs ((o function) (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((o function)) (let ((header (kernel:get-type o))) (cond ((= header vm:function-header-type) (values (format nil "~A is a function." o) @@ -1789,8 +1788,7 @@ (call-next-method))))) -(defmethod inspect-for-emacs ((o kernel:code-component) (_ backend-inspector)) - (declare (ignore _)) +(defmethod inspect-for-emacs ((o kernel:code-component)) (values (format nil "~A is a code data-block." o) (append (label-value-line* @@ -1817,8 +1815,7 @@ (ash (kernel:%code-code-size o) vm:word-shift) :stream s)))))))) -(defmethod inspect-for-emacs ((o kernel:fdefn) (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((o kernel:fdefn)) (values (format nil "~A is a fdenf object." o) (label-value-line* ("name" (kernel:fdefn-name o)) @@ -1827,8 +1824,7 @@ (sys:int-sap (kernel:get-lisp-obj-address o)) (* vm:fdefn-raw-addr-slot vm:word-bytes)))))) -(defmethod inspect-for-emacs ((o array) (inspector backend-inspector)) - inspector +(defmethod inspect-for-emacs ((o array)) (cond ((kernel:array-header-p o) (values (format nil "~A is an array." o) (label-value-line* @@ -1847,8 +1843,7 @@ (:header (describe-primitive-type o)) (:length (length o))))))) -(defmethod inspect-for-emacs ((o simple-vector) (inspector backend-inspector)) - inspector +(defmethod inspect-for-emacs ((o simple-vector)) (values (format nil "~A is a vector." o) (append (label-value-line* Modified: branches/trunk-reorg/thirdparty/slime/swank.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank.lisp Thu Feb 7 03:32:58 2008 @@ -415,43 +415,6 @@ (<= (char-code c) 127)) -;;;;; Misc - -(defun length= (seq n) - "Test for whether SEQ contains N number of elements. I.e. it's equivalent - to (= (LENGTH SEQ) N), but besides being more concise, it may also be more - efficiently implemented." - (etypecase seq - (list (do ((i n (1- i)) - (list seq (cdr list))) - ((or (<= i 0) (null list)) - (and (zerop i) (null list))))) - (sequence (= (length seq) n)))) - -(defun ensure-list (thing) - (if (listp thing) thing (list thing))) - -(defun recursively-empty-p (list) - "Returns whether LIST consists only of arbitrarily nested empty lists." - (cond ((not (listp list)) nil) - ((null list) t) - (t (every #'recursively-empty-p list)))) - -(defun maybecall (bool fn &rest args) - "Call FN with ARGS if BOOL is T. Otherwise return ARGS as multiple values." - (if bool (apply fn args) (values-list args))) - -(defun exactly-one-p (&rest values) - "If exactly one value in VALUES is non-NIL, this value is returned. -Otherwise NIL is returned." - (let ((found nil)) - (dolist (v values) - (when v (if found - (return-from exactly-one-p nil) - (setq found v)))) - found)) - - ;;;;; Symbols (defun symbol-status (symbol &optional (package (symbol-package symbol))) @@ -1569,30 +1532,6 @@ (let ((*read-suppress* nil)) (read-from-string string)))) -(defun read-softly-from-string (string) - "Returns three values: - - 1. the object resulting from READing STRING. - - 2. The index of the first character in STRING that was not read. - - 3. T if the object is a symbol that had to be newly interned - in some package. (This does not work for symbols in - compound forms like lists or vectors.)" - (multiple-value-bind (symbol found? symbol-name package) (parse-symbol string) - (if found? - (values symbol (length string) nil) - (multiple-value-bind (sexp pos) (read-from-string string) - (values sexp pos - (when (symbolp sexp) - (prog1 t - ;; assert that PARSE-SYMBOL didn't parse incorrectly. - (assert (and (equal symbol-name (symbol-name sexp)) - (eq package (symbol-package sexp))))))))))) - -(defun unintern-in-home-package (symbol) - (unintern symbol (symbol-package symbol))) - ;; FIXME: deal with #\| etc. hard to do portably. (defun tokenize-symbol (string) "STRING is interpreted as the string representation of a symbol @@ -1755,7 +1694,7 @@ (with-buffer-syntax () (let ((*print-readably* nil)) (cond ((null values) "; No value") - ((and (length= values 1) (integerp (car values))) + ((and (integerp (car values)) (null (cdr values))) (let ((i (car values))) (format nil "~A~D (#x~X, #o~O, #b~B)" *echo-area-prefix* i i i i))) @@ -2056,12 +1995,15 @@ ,(princ-to-string real-condition)))) (throw 'sldb-loop-catcher nil)) +(defvar *sldb-condition-printer* #'format-sldb-condition + "Function called to print a condition to an SLDB buffer.") + (defun safe-condition-message (condition) "Safely print condition to a string, handling any errors during printing." (let ((*print-pretty* t) (*print-right-margin* 65)) (handler-case - (format-sldb-condition condition) + (funcall *sldb-condition-printer* condition) (error (cond) ;; Beware of recursive errors in printing, so only use the condition ;; if it is printable itself: @@ -2750,8 +2692,7 @@ (set-pprint-dispatch '(cons (member function)) nil) (princ-to-string list))) -(defmethod inspect-for-emacs ((object cons) inspector) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((object cons)) (if (consp (cdr object)) (inspect-for-emacs-list object) (inspect-for-emacs-simple-cons object))) @@ -2811,8 +2752,7 @@ a hash table or array to show by default. If table has more than this then offer actions to view more. Set to nil for no limit." ) -(defmethod inspect-for-emacs ((ht hash-table) inspector) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((ht hash-table)) (values (prin1-to-string ht) (append (label-value-line* @@ -2864,8 +2804,7 @@ (progn (format t "How many elements should be shown? ") (read)))) (swank::inspect-object thing))))) -(defmethod inspect-for-emacs ((array array) inspector) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((array array)) (values "An array." (append (label-value-line* @@ -2883,8 +2822,7 @@ (loop for i below (or *slime-inspect-contents-limit* (array-total-size array)) append (label-value-line i (row-major-aref array i)))))) -(defmethod inspect-for-emacs ((char character) inspector) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((char character)) (values "A character." (append (label-value-line* @@ -2903,7 +2841,6 @@ (defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0)) (declaim (type vector *inspector-history*)) (defvar *inspect-length* 30) -(defvar *default-inspector* (make-default-inspector)) (defun reset-inspector () (setq *inspectee* nil @@ -2912,14 +2849,6 @@ *inspectee-actions* (make-array 10 :adjustable t :fill-pointer 0) *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))) -(defun valid-function-name-p (form) - (or (symbolp form) - (and (consp form) - (second form) - (not (third form)) - (eq (first form) 'setf) - (symbolp (second form))))) - (defslimefun init-inspector (string) (with-buffer-syntax () (reset-inspector) @@ -2960,14 +2889,14 @@ (list :action label (assign-index (list lambda refreshp) *inspectee-actions*))) -(defun inspect-object (object &optional (inspector *default-inspector*)) +(defun inspect-object (object) (push (setq *inspectee* object) *inspector-stack*) (unless (find object *inspector-history*) (vector-push-extend object *inspector-history*)) (let ((*print-pretty* nil) ; print everything in the same line (*print-circle* t) (*print-readably* nil)) - (multiple-value-bind (_ content) (inspect-for-emacs object inspector) + (multiple-value-bind (_ content) (inspect-for-emacs object) (declare (ignore _)) (list :title (with-output-to-string (s) (print-unreadable-object (object s :type t :identity t)))

1 0

[bknr-cvs] r2451 - in branches/trunk-reorg/bknr: datastore/src/data datastore/src/utils web/src web/src/rss web/src/web
by hhubner＠common-lisp.net 07 Feb '08

07 Feb '08

Author: hhubner Date: Thu Feb 7 03:30:34 2008 New Revision: 2451 Modified: branches/trunk-reorg/bknr/datastore/src/data/object.lisp branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp branches/trunk-reorg/bknr/web/src/bknr-web.asd branches/trunk-reorg/bknr/web/src/packages.lisp branches/trunk-reorg/bknr/web/src/rss/rss.lisp branches/trunk-reorg/bknr/web/src/web/handlers.lisp branches/trunk-reorg/bknr/web/src/web/host.lisp branches/trunk-reorg/bknr/web/src/web/template-handler.lisp Log: save current state Modified: branches/trunk-reorg/bknr/datastore/src/data/object.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/data/object.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/data/object.lisp Thu Feb 7 03:30:34 2008 @@ -574,8 +574,7 @@ (if restoring (remove-transient-slot-initargs (find-class class-name) initargs) initargs))) - (unless restoring - (initialize-persistent-instance obj)) + (initialize-persistent-instance obj) (initialize-transient-instance obj) (setf error nil) obj) Modified: branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp Thu Feb 7 03:30:34 2008 @@ -511,7 +511,7 @@ (with-open-file (s pathname :element-type '(unsigned-byte 8)) (let ((result (make-array (file-length s) :element-type '(unsigned-byte 8)))) - (read-sequence result s ) + (read-sequence result s) result))) (defun class-subclasses (class) Modified: branches/trunk-reorg/bknr/web/src/bknr-web.asd ============================================================================== --- branches/trunk-reorg/bknr/web/src/bknr-web.asd (original) +++ branches/trunk-reorg/bknr/web/src/bknr-web.asd Thu Feb 7 03:30:34 2008 @@ -31,6 +31,7 @@ :hunchentoot :xhtmlgen :puri + :usocket :bknr-datastore :bknr-data-impex :parenscript) Modified: branches/trunk-reorg/bknr/web/src/packages.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/packages.lisp (original) +++ branches/trunk-reorg/bknr/web/src/packages.lisp Thu Feb 7 03:30:34 2008 @@ -263,6 +263,7 @@ ;; templates #:expand-template + #:expand-variables #:get-template-var #:with-template-vars #:emit-template-node @@ -313,6 +314,7 @@ #:object-handler #:edit-object-handler #:template-handler + #:template-handler-destination #:page-handler #:page-handler-prefix #:page-handler-site Modified: branches/trunk-reorg/bknr/web/src/rss/rss.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/rss/rss.lisp (original) +++ branches/trunk-reorg/bknr/web/src/rss/rss.lisp Thu Feb 7 03:30:34 2008 @@ -129,7 +129,7 @@ (remove-item (rss-item-channel rss-item) rss-item)) (defun item-slot-element (item slot-name) - (let ((accessor (kmrcl:concat-symbol-pkg (find-package :bknr.rss) 'rss-item- slot-name))) + (let ((accessor (find-symbol (format nil "RSS-ITEM-~A" slot-name) (find-package :bknr.rss)))) (aif (funcall accessor item) (with-element (string-downcase (symbol-name slot-name)) (text it))))) Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/handlers.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/handlers.lisp Thu Feb 7 03:30:34 2008 @@ -557,4 +557,4 @@ (defun unpublish () (setf *dispatch-table* (remove 'bknr-handler *dispatch-table*) - *handlers* nil)) \ No newline at end of file + *handlers* nil)) Modified: branches/trunk-reorg/bknr/web/src/web/host.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/host.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/host.lisp Thu Feb 7 03:30:34 2008 @@ -46,11 +46,11 @@ (host-ip-address host))) (defmethod host-ipaddr ((host host)) - (kmrcl::dotted-to-ipaddr (host-ip-address host))) + (usocket:host-byte-order (host-ip-address host))) (defun find-host (&key ip-address create ipaddr) (when ipaddr - (setf ip-address (kmrcl::ipaddr-to-dotted ipaddr))) + (setf ip-address (usocket:hbo-to-dotted-quad ipaddr))) (or (host-with-ipaddress ip-address) (and create (make-object 'host :ip-address ip-address)))) Modified: branches/trunk-reorg/bknr/web/src/web/template-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/template-handler.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/template-handler.lisp Thu Feb 7 03:30:34 2008 @@ -92,7 +92,7 @@ ,(intern (symbol-name var) :keyword))))) ,@body)) -(defun expand-variables (string) +(defun expand-variables (string lookup-variable) (if (find #\$ string) (regex-replace-all #?r"\$$([\*_-\w]+)$" string @@ -101,7 +101,7 @@ (let* ((var (make-keyword-from-string (subseq target-string (aref reg-starts 0) (aref reg-ends 0)))) - (val (get-template-var var))) + (val (funcall lookup-variable var))) (cond ((stringp val) val) ((null val) "") @@ -136,7 +136,7 @@ (defun emit-template-node (expander node) (if (stringp node) - (sax:characters *html-sink* (expand-variables node)) + (sax:characters *html-sink* (expand-variables node #'get-template-var)) (let* ((name (node-name node)) (ns (node-ns node)) (children (node-children node)) @@ -148,10 +148,10 @@ (apply (find-tag-function expander name ns) (append (loop for (key name) in attrs collect (make-keyword-from-string key) - collect (expand-variables name)))))) + collect (expand-variables name #'get-template-var)))))) (t (sax:start-element *html-sink* nil nil name - (xmls-attributes-to-sax #'expand-variables attrs)) + (xmls-attributes-to-sax (rcurry #'expand-variables #'get-template-var) attrs)) (dolist (child children) (emit-template-node expander child)) (sax:end-element *html-sink* nil nil name))))))

1 0

[bknr-cvs] r2450 - in branches/trunk-reorg/thirdparty/acl-compat: . allegro clisp cmucl lispworks mcl sbcl scl
by hhubner＠common-lisp.net 07 Feb '08

07 Feb '08

Author: hhubner Date: Thu Feb 7 03:21:48 2008 New Revision: 2450 Added: branches/trunk-reorg/thirdparty/acl-compat/ branches/trunk-reorg/thirdparty/acl-compat/CREDITS branches/trunk-reorg/thirdparty/acl-compat/ChangeLog branches/trunk-reorg/thirdparty/acl-compat/README branches/trunk-reorg/thirdparty/acl-compat/acl-compat-cmu.system branches/trunk-reorg/thirdparty/acl-compat/acl-compat-common-lisp-lw.lisp branches/trunk-reorg/thirdparty/acl-compat/acl-compat-corman.lisp branches/trunk-reorg/thirdparty/acl-compat/acl-compat.asd branches/trunk-reorg/thirdparty/acl-compat/acl-excl-common.lisp branches/trunk-reorg/thirdparty/acl-compat/acl-excl-corman.lisp branches/trunk-reorg/thirdparty/acl-compat/acl-mp-corman.lisp branches/trunk-reorg/thirdparty/acl-compat/acl-mp-package.lisp branches/trunk-reorg/thirdparty/acl-compat/acl-socket-corman.lisp branches/trunk-reorg/thirdparty/acl-compat/acl-ssl-streams.lisp branches/trunk-reorg/thirdparty/acl-compat/acl-ssl.lisp branches/trunk-reorg/thirdparty/acl-compat/allegro/ branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-excl.lisp branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-mp.lisp branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-socket.lisp branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-sys.lisp branches/trunk-reorg/thirdparty/acl-compat/chunked-stream-mixin.lisp branches/trunk-reorg/thirdparty/acl-compat/chunked.lisp (contents, props changed) branches/trunk-reorg/thirdparty/acl-compat/clisp/ branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-excl.lisp branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-mp.lisp branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-socket.lisp branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-sys.lisp branches/trunk-reorg/thirdparty/acl-compat/cmucl/ branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-excl.lisp branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-mp.lisp branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-socket.lisp branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-sys.lisp branches/trunk-reorg/thirdparty/acl-compat/defsys.lisp branches/trunk-reorg/thirdparty/acl-compat/lispworks/ branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-excl.lisp branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-mp.lisp branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-socket.lisp branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-sys.lisp branches/trunk-reorg/thirdparty/acl-compat/lw-buffering.lisp branches/trunk-reorg/thirdparty/acl-compat/mcl/ branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-excl.lisp branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-mp.lisp branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-socket-mcl.lisp branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-socket-openmcl.lisp branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-sys.lisp branches/trunk-reorg/thirdparty/acl-compat/mcl/mcl-stream-fix.lisp branches/trunk-reorg/thirdparty/acl-compat/mcl/mcl-timers.lisp branches/trunk-reorg/thirdparty/acl-compat/packages.lisp branches/trunk-reorg/thirdparty/acl-compat/sbcl/ branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-excl.lisp branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-mp.lisp branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-socket.lisp branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-sys.lisp branches/trunk-reorg/thirdparty/acl-compat/scl/ branches/trunk-reorg/thirdparty/acl-compat/scl/acl-excl.lisp branches/trunk-reorg/thirdparty/acl-compat/scl/acl-mp.lisp branches/trunk-reorg/thirdparty/acl-compat/scl/acl-socket.lisp branches/trunk-reorg/thirdparty/acl-compat/scl/acl-sys.lisp branches/trunk-reorg/thirdparty/acl-compat/test-acl-socket.lisp (contents, props changed) Log: add acl-compat Added: branches/trunk-reorg/thirdparty/acl-compat/CREDITS ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/CREDITS Thu Feb 7 03:21:48 2008 @@ -0,0 +1,59 @@ +-*- text -*- + +CREDITS; a.k.a. the history of Portable AllegroServe + +This was written by Rudi Schlatte, who (knowing himself) is sure he +forgot some important contributors. Please mail me (rudi at +constantly.at) to point out any inconsistencies, don't be shy! + +* Corman Lisp + +The code that started it all. Chris Double took Allegro's +open-sourced code, got it to run on Corman Lisp and released the +code.. After Portable AllegroServe got off the ground, he re-arranged +his port so that it fit in the structure of acl-compat. + +* Xanalys LispWorks + +Jochen Schmidt ported Chris Double's AllegroServe port to LispWorks, +laid the groundwork for the "Portable" part of paserve and started +the SourceForge project. + +* cmucl + +cmucl was the third Lisp implementation to run Portable +AllegroServe. The port was done by Rudi Schlatte during his military +service out of sheer boredom. + +* Digitool MCL + +John DeSoi contributed this port and kept it working when the antics +of other developers broke his code once again. + +* OpenMCL + +Also done by John DeSoi. Gary Byers himself later contributed code to +support OpenMCL's OS-level threads (OpenMCL version 14 and up) in an +efficient way. + +* sbcl + +This port was done by Rudi Schlatte, using Daniel Barlow's sbcl +multiprocessing code in the McCLIM GUI project as inspiration. + +* clisp + +Also by Rudi Schlatte. Since clisp has no support for threads, +neither does acl-compat on this platform. Code can still be +compiled, however. + +* Scieneer Common Lisp + +This port was contributed by Douglas Crosher. + +* Allegro Common Lisp + +It may seem strange to implement an API on top of itself, but Kevin +Rosenberg's implementation makes it possible to run systems that use +acl-compat on ACL itself without source changes. + Added: branches/trunk-reorg/thirdparty/acl-compat/ChangeLog ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/ChangeLog Thu Feb 7 03:21:48 2008 @@ -0,0 +1,354 @@ +2006-01-22 Rudi Schlatte <rudi(a)constantly.at> + + * sbcl/acl-mp.lisp (defun/sb-thread): silence compilation style + warning on single-threaded sbcl + + * sbcl/acl-excl.lisp (filesys-type): Fix bogus variable name :( + +2006-01-21 Rudi Schlatte <rudi(a)constantly.at> + + * sbcl/acl-excl.lisp (filesys-type, filesys-inode): use sb-posix + instead of sbcl internals + +2005-08-05 Gabor Melis <mega(a)hotpop.com> + + * sbcl/acl-mp.lisp: updated to use the thread object api + available since sbcl 0.9.2 + +2004-02-17 Rudi Schlatte <rudi(a)SLAW40.kfunigraz.ac.at> + + * acl-excl-common.lisp (match-regexp): Make :return :index return + values same as ACL + +2004-02-16 Rudi Schlatte <rudi(a)62-99-252-74.C-GMITTE.Xdsl-line.inode.at> + + * acl-compat.asd: + - Add some meta-information to system definition + - Fix bug: all but the first :depends-on arguments are silently + ignored. :/ + +2004-02-16 Rudi Schlatte <rudi(a)constantly.at> + + * packages.lisp: Remove references to nregex package. + + * acl-excl-common.lisp (match-regexp, compile-regexp): Implement + using cl-ppcre. + + * acl-compat.asd: Eliminate meta and nregex, use cl-ppcre instead. + +2004-02-14 Rudi Schlatte <rudi(a)constantly.at> + + * acl-compat.asd: Make Gray streams loading on cmucl a little bit + saner (but only a little bit) + + * chunked-stream-mixin.lisp: Don't add to *features*, remove + provide form. + +2004-02-08 Rudi Schlatte <rudi(a)constantly.at> + + * acl-compat.asd: Introduce dependency on puri, remove meta and + uri.lisp + +2004-02-02 Rudi Schlatte <rudi(a)constantly.at> + + * cmucl/acl-mp.lisp (process-run-function): Give the new process + a run reason, so that it doesn't hang from the start. + + * cmucl/acl-socket.lisp (get-fd): Added method for server-socket. + +2004-01-28 Rudi Schlatte <rudi(a)constantly.at> + + * packages.lisp: excl -> acl-compat.excl + + * lispworks/acl-socket.lisp: ditto. + +2004-01-27 Rudi Schlatte <rudi(a)constantly.at> + + * chunked-stream-mixin.lisp: replace excl: package prefix with + acl-compat.excl: + +2004-01-26 Rudi Schlatte <rudi(a)constantly.at> + + * mcl/acl-excl.lisp (fixnump): new function. + + * packages.lisp (:acl-compat.excl): Remove "excl" nickname. + + * clisp/acl-excl.lisp (fixnump): new function. + +2004-01-24 Rudi Schlatte <rudi(a)constantly.at> + + * acl-excl-common.lisp (string-to-octets): null-terminate vector + when asked to. + + * cmucl/acl-excl.lisp, lispworks/acl-excl.lisp, mcl/acl-excl.lisp, + sbcl/acl-excl.lisp, scl/acl-excl.lisp: Move write-vector, + string-to-octets to commmon file. + + * acl-excl-common.lisp: Moved write-vector, string-to-octets from + implementation-specific files. + +2004-01-19 Rudi Schlatte <rudi(a)constantly.at> + + * scl/acl-excl.lisp, sbcl/acl-excl.lisp, mcl/acl-excl.lisp, + lispworks/acl-excl.lisp, cmucl/acl-excl.lisp, + clisp/acl-excl.lisp: Remove common functionality from + implementation-specific files, dammit! + + * acl-compat.asd: Added acl-excl-common. + + * acl-excl-common.lisp: New file. + +2004-01-18 Rudi Schlatte <rudi(a)62-99-252-74.C-GMITTE.Xdsl-line.inode.at> + + * acl-excl-corman.lisp (intern*), sbcl/acl-excl.lisp (intern*), + mcl/acl-excl.lisp (intern*), lispworks/acl-excl.lisp (intern*), + cmucl/acl-excl.lisp (intern*), clisp/acl-excl.lisp (intern*), + scl/acl-excl.lisp (intern*): Don't upcase symbol before interning + (thanks to Marco Baringer, whose code was broken by this). Now + I'm motivated to factor out common code from all the backends ... + + * cmucl/acl-mp.lisp (apply-with-bindings): Fix "How did this ever + work" typo; thanks to Marco Baringer. + +2004-01-11 Rudi Schlatte <rudi(a)constantly.at> + + * sbcl/acl-socket.lisp (make-socket): Handle :local-port nil, + don't bind socket in that case (let os choose a port) + +2004-01-11 Rudi Schlatte <rudi(a)constantly.at> + + * packages.lisp (defpackage acl-compat.excl): Export some symbols + for mcl, too + + * mcl/acl-excl.lisp (run-shell-command): Implement (largely + untested for now, needed for cgi support) + + * mcl/acl-sys.lisp (command-line-argument, + command-line-arguments): Implement for OpenMCL + + * mcl/acl-mp.lisp (wait-for-input-available): Implement. Needed + for cgi support. + + * mcl/acl-socket-openmcl.lisp (server-socket): Remove :type slot + argument. + + * sbcl/acl-socket.lisp (make-socket): Add reuse-address argument. + + * cmucl/acl-socket.lisp (make-socket): Add reuse-address argument. + + * acl-compat.asd: Load sb-posix for sbcl. + +2003-12-15 Rudi Schlatte <rudi(a)constantly.at> + + NOTE: this checkin has a reasonable chance of breaking (and mcl + (not openmcl)) + + * mcl/acl-socket-openmcl.lisp: Remove package definition, + implement chunked transfer encoding (accepting a speed loss in the + process) + + * mcl/acl-excl.lisp, mcl/acl-mp.lisp, mcl/acl-sys.lisp: remove + package definitions + + * uri.lisp: deftype also at load time; openmcl breaks otherwise + + * packages.lisp: mcl doesn't have stream-(read,write)-sequence + + * lw-buffering.lisp: formatting frobs. + + * acl-compat.asd: Merge mcl defsystem with the others. + + * sbcl/acl-socket.lisp: Use acl-compat.socket package name. + +2003-12-02 Rudi Schlatte <rudi(a)SLAW40.kfunigraz.ac.at> + + * meta.lisp (enable-meta-syntax): Save current readtable before + installing *meta-readtable*. + +2003-12-01 Rudi Schlatte <rudi(a)constantly.at> + + * chunked-stream-mixin.lisp: Merge Lispworks patch from Edi Weitz + (paserve-help 2003-11-28) + +2003-11-27 Rudi Schlatte <rudi(a)constantly.at> + + * chunked-stream-mixin.lisp (gray-stream:stream-fill-buffer): + LispWorks refill-buffer does not always return the amount of + bytes read (reported by Edi Weitz to paserve-discuss + 2003-11-26). Treat its return value as a boolean. + + * lw-buffering.lisp (stream-fill-buffer): Remove cmucl-specific + read-n-bytes call because it does block after all :( + + * chunked-stream-mixin.lisp (gray-stream:stream-fill-buffer): Fix + for Lispworks client mode contributed by Edi Weitz to + paserve-discuss list on 2003-11-25 + + * sbcl/acl-mp.lisp: Single-threaded "implementation" of process-name + +2003-09-19 Rudi Schlatte <rudi(a)constantly.at> + + * sbcl/acl-mp.lisp: Merged threading patch from Brian Downing + (posted to portableaserve-discuss 2003-09-12) + + * clisp/acl-excl.lisp, clisp/acl-socket.lisp: Eliminate compile + failures, activate chunked support for clisp (forwarded by Kevin + M. Rosenberg from Debian) + +2003-08-31 Rudi Schlatte <rudi(a)constantly.at> + + * acl-compat.asd: Remove old cmu-read-sequence cruft, bug is fixed + in reasonably recent cmucl + + * lw-buffering.lisp (stream-fill-buffer): Use package-external + symbol that doesn't break on CVS cmucl + +2003-08-30 Rudi Schlatte <rudi(a)62-99-252-74.C-GMITTE.Xdsl-line.inode.at> + + * cmucl/acl-socket.lisp (make-socket): set reuse-address option. + + * lw-buffering.lisp (stream-fill-buffer): Implement b/nb semantics + for cmucl as well. client mode should now neither hang trying to + read closed streams nor give spurious errors for slow servers. + +2003-08-17 Rudi Schlatte <rudi(a)constantly.at> + + * sbcl/acl-mp.lisp (with-timeout): Eliminate unused-variable + warning. + +2003-05-13 Rudi Schlatte <rudi(a)constantly.at> + + * cmucl/acl-sys.lisp, cmucl/acl-socket.lisp, cmucl/acl-excl.lisp: + Use correct package names in in-package forms (Reported by Johan + Parin) + + * packages.lisp (acl-compat.system): Add nickname acl-compat.sys, + remove commented-out nicknames. + + * lispworks/acl-sys.lisp: push MSWINDOWS onto *features* if + appropriate (Thanks to Alain Picard for the report). + +2003-05-11 Rudi Schlatte <rudi(a)constantly.at> + + * acl-compat.asd: Don't load read-/write-sequence patches on cmucl + 18e. + +2003-05-06 Rudi Schlatte <rudi(a)constantly.at> + + * lw-buffering.lisp (stream-fill-buffer): Implement + blocking/non-blocking semantics (read at least one byte per + fill-buffer call). Otherwise we'd get spurious EOFs with slow + servers. + + * chunked-stream-mixin.lisp (gray-stream:stream-fill-buffer): + Return a sensible value (amount of bytes that can be read before + next call to fill-buffer). + +2003-05-03 Rudi Schlatte <rudi(a)constantly.at> + + * chunked-stream-mixin.lisp (gray-stream:stream-fill-buffer): Make + input-chunking work, refactor somewhat to make all slot changes in + one place. + +2003-05-02 Rudi Schlatte <rudi(a)constantly.at> + + * acl-compat.asd (acl-compat): Current cmucl versions handle Gray + streams in (read,write)-sequence -- remove hack + +2003-04-30 Rudi Schlatte <rudi(a)constantly.at> + + * sbcl/acl-mp.lisp (with-timeout): Use timeout symbols from the + ext package; latest cvs exports them + + * cmucl/acl-mp.lisp: Use acl-compat.mp package name. + + * acl-compat.asd et al: The Great Renaming: begin move of + implementation-dependent files into subdirectories + +2003-04-27 Rudi Schlatte <rudi(a)constantly.at> + + * acl-socket-sbcl.lisp: Implemented peername lookup (by storing + the socket in the plist of the bivalent stream object for now) + +2003-04-26 Rudi Schlatte <rudi(a)constantly.at> + + * acl-mp-sbcl.lisp: Add initial support for multi-threaded sbcl + +2003-04-08 Rudi Schlatte <rudi(a)constantly.at> + + * uri.lisp (render-uri): Reinstate with-output-to-string logic; + render-uri has to handle nil as a stream value. + +2003-04-03 Rudi Schlatte <rudi(a)constantly.at> + + * uri.lisp (render-uri, print-object): Further frob printing of + URIs, inspired by patch of Harley Gorrell + +2003-04-02 Rudi Schlatte <rudi(a)constantly.at> + + * uri.lisp (render-uri): Fix printing URIs in the presence of #\~ + (Thanks to Harley Gorrell) + +2003-03-24 Rudi Schlatte <rudi(a)constantly.at> + + * lw-buffering.lisp (stream-write-buffer, stream-flush-buffer): + Eliminate "wait" parameter to regain api-compatibility with lispworks + (stream-finish-output, stream-force-output): Call (finish|force)-output + here instead of using "wait" parameter of stream-flush-buffer + + * chunked-stream-mixin.lisp: some documentation added, formatting, + eliminate use of "wait" parameter on stream-write-buffer etc. + +2003-02-28 Rudi Schlatte <rudi(a)constantly.at> + + * acl-socket-sbcl.lisp: + (remote-host, remote-port, local-host, local-port): Change return + value to something convertible to an (invalid) inet address + + * acl-compat.asd, packages.lisp: Support sbcl 0.7.13 single-threaded + +2002-12-26 Rudi Schlatte <rudi(a)constantly.at> + + * lw-buffering.lisp (write-elements): end argument value can be + nil (fix contributed by Simon Andras 2002-12-24) + + * meta.lisp: Switch to new-style eval-when times + + * lw-buffering.lisp: Switch to new-style eval-when times + (defstruct buffer-state): Add type declarations + (stream-fill-buffer): Remove bug for non-cmucl case (need + unblocking read-sequence) + + * chunked-stream-mixin.lisp: Add defgeneric forms + + * acl-socket-sbcl.lisp: Enable chunked transfer encoding support + +2002-12-23 Rudi Schlatte <rudi(a)constantly.at> + + * packages.lisp, acl-sys-sbcl.lisp: Various sbcl fixes + +2002-12-18 Rudi Schlatte <rudi(a)constantly.at> + + * packages.lisp: Add package definition of + de.dataheaven.chunked-stream-mixin, remove nicknames for + acl-compat.system + +2002-12-17 Rudi Schlatte <rudi(a)constantly.at> + + * (Module): Added first stab at sbcl support (some stub + functions, basic page serving works) + +2002-12-13 Rudi Schlatte <rudi(a)constantly.at> + + * lw-buffering.lisp (stream-write-sequence): Make publish-multi + work (provide default value for start arg). + + * acl-excl-cmu.lisp (write-vector): ditto. + +2002-12-03 Rudi Schlatte <rudi(a)constantly.at> + + * acl-compat.asd: load lw-buffering in every implementation except + lispworks + + * packages.lisp: define gray-stream package for every + implementation Added: branches/trunk-reorg/thirdparty/acl-compat/README ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/README Thu Feb 7 03:21:48 2008 @@ -0,0 +1,33 @@ +-*- text -*- + +acl-compat is a library that implements parts of the Allegro Common +Lisp (ACL) API for areas that are not covered by the ANSI Common Lisp +standard itself (e.g. sockets, threading). The motivation for +creating and maintaining acl-compat is to get the web server +AllegroServe (that was released by Franz Inc under the LLGPL) running +on a wide range of Lisp implementations, with as few source changes to +its core code as possible. + +acl-compat names its packages by prepending the corresponding ACL +package name with the string "ACL-COMPAT.". For example, the ACL +threading API symbols are exported from the package ACL-COMPAT.MP. +Ideally, ACL-specific code could run on any supported Lisp +implementation only by changing package references. + +Of course, the present situation is not ideal. :( Functionality is +only implemented on an as-needed basis, implemented functions don't +handle all argument combinations properly, etc. On the other hand, +enough is implemented to support a web and application server that +exercises a wide range of functionality (client and server sockets, +threading, etc.). + + +To load acl-compat: + +- install asdf (see < http://www.cliki.net/asdf >) and make sure it's + loaded. + +- load acl-compat.asd + +- evaluate (asdf:operate 'asdf:load-op :acl-compat) + Added: branches/trunk-reorg/thirdparty/acl-compat/acl-compat-cmu.system ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/acl-compat-cmu.system Thu Feb 7 03:21:48 2008 @@ -0,0 +1,36 @@ +;;; -*- mode: lisp -*- + +(in-package :CL-USER) + +;; Stig: we're a debian-package if clc is present +;; Rudi: Not if kludge-no-cclan is also present +#+(and common-lisp-controller (not kludge-no-cclan)) +(setf (logical-pathname-translations "acl-compat") + '(("**;*.*.*" "cl-library:;acl-compat;**;*.*.*"))) + +(mk:defsystem "ACL-COMPAT" + :source-pathname (make-pathname :directory + (pathname-directory *load-truename*)) ;"acl-compat:" +; :source-extension "lisp" +; :binary-pathname nil +; :binary-extension nil + :components ((:file "nregex") + (:file "packages" :depends-on ("nregex")) + (:file "lw-buffering" :depends-on ("packages")) + (:file "acl-mp-cmu" :depends-on ("packages")) + (:file "acl-excl-cmu" :depends-on ("packages" "nregex")) + (:file "cmu-read-sequence") + (:file "acl-socket-cmu" + :depends-on ("packages" "acl-excl-cmu" + "chunked-stream-mixin" + "cmu-read-sequence")) + (:file "acl-sys-cmu" :depends-on ("packages")) + (:file "meta") + (:file "uri" :depends-on ("meta")) + (:file "chunked-stream-mixin" + :depends-on ("packages" "acl-excl-cmu" + "lw-buffering"))) + ;; Stig: if we're CMU and a debian-package, we need graystreams + #+(and cmu common-lisp-controller) + :depends-on + #+(and cmu common-lisp-controller) (cmucl-graystream)) Added: branches/trunk-reorg/thirdparty/acl-compat/acl-compat-common-lisp-lw.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/acl-compat-common-lisp-lw.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,21 @@ +(defpackage acl-compat-common-lisp + (:use common-lisp) + (:shadow make-hash-table) + (:export make-hash-table)) + +(in-package :acl-compat-common-lisp) + +(defun make-hash-table (&rest args &key test size rehash-size rehash-threshold (hash-function nil h-f-p) + (values t) weak-keys) + (declare (ignore hash-function)) + (when h-f-p (error "User defined hash-functions are not supported.")) + (let ((table (apply #'cl:make-hash-table :allow-other-keys t args))) + (hcl:set-hash-table-weak table + (if weak-keys + (if (eq values :weak) + :both + :key) + (if (eq values :weak) + :value + nil))) + table)) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/acl-compat/acl-compat-corman.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/acl-compat-corman.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,13 @@ +(require 'gray-streams) +(in-package :cl-user) + +(defvar *acl-compat-directory* "d:/projects/lisp/portableaserve/acl-compat/") +(load (concatenate 'string *acl-compat-directory* "nregex.lisp")) +(load (concatenate 'string *acl-compat-directory* "meta.lisp")) +(load (concatenate 'string *acl-compat-directory* "acl-excl-corman.lisp")) +(load (concatenate 'string *acl-compat-directory* "acl-mp-corman.lisp")) +(load (concatenate 'string *acl-compat-directory* "acl-socket-corman.lisp")) +(load (concatenate 'string *acl-compat-directory* "uri.lisp")) +(load (concatenate 'string *acl-compat-directory* "packages.lisp")) + +(pushnew :acl-compat *features*) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/acl-compat/acl-compat.asd ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/acl-compat.asd Thu Feb 7 03:21:48 2008 @@ -0,0 +1,182 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; This as an ASDF system for ACL-COMPAT, meant to replace +;;;; acl-compat-cmu.system, but could replace all other systems, too. +;;;; (hint, hint) + +(defpackage #:acl-compat-system + (:use #:cl #:asdf)) +(in-package #:acl-compat-system) + +;;;; gray stream support for cmucl: Debian/common-lisp-controller has +;;;; a `cmucl-graystream' system; if this is not found, we assume a +;;;; cmucl downloaded from cons.org, where Gray stream support resides +;;;; in the subsystems/ directory. + + +#+cmu +(progn + +(defclass precompiled-file (static-file) + ()) + +(defmethod perform ((operation load-op) (c precompiled-file)) + (load (component-pathname c))) + +(defmethod operation-done-p ((operation load-op) (c precompiled-file)) + nil) + +#-gray-streams +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (asdf:find-system :cmucl-graystream nil) + (asdf:defsystem cmucl-graystream + :pathname (make-pathname + :name nil :type nil :version nil + :defaults (truename "library:subsystems/gray-streams-library.x86f")) + :components ((:precompiled-file "gray-streams-library.x86f"))))) +) + +;;;; ignore warnings +;;;; +;;;; FIXME: should better fix warnings instead of ignoring them +;;;; FIXME: (perform legacy-cl-sourcefile) duplicates ASDF code + +(defclass legacy-cl-source-file (cl-source-file) + () + (:documentation + "Common Lisp source code module with (non-style) warnings. +In contrast to CL-SOURCE-FILE, this class does not think that such warnings +indicate failure.")) + +(defmethod perform ((operation compile-op) (c legacy-cl-source-file)) + (let ((source-file (component-pathname c)) + (output-file (car (output-files operation c))) + (warnings-p nil) + (failure-p nil)) + (setf (asdf::component-property c 'last-compiled) nil) + (handler-bind ((warning (lambda (c) + (declare (ignore c)) + (setq warnings-p t))) + ;; _not_ (or error (and warning (not style-warning))) + (error (lambda (c) + (declare (ignore c)) + (setq failure-p t)))) + (compile-file source-file + :output-file output-file)) + ;; rest of this method is as for CL-SOURCE-FILE + (setf (asdf::component-property c 'last-compiled) (file-write-date output-file)) + (when warnings-p + (case (asdf::operation-on-warnings operation) + (:warn (warn "COMPILE-FILE warned while performing ~A on ~A" + c operation)) + (:error (error 'compile-warned :component c :operation operation)) + (:ignore nil))) + (when failure-p + (case (asdf::operation-on-failure operation) + (:warn (warn "COMPILE-FILE failed while performing ~A on ~A" + c operation)) + (:error (error 'compile-failed :component c :operation operation)) + (:ignore nil))))) + +;;; +;;; This is thought to reduce reader-conditionals in the system definition +;;; +(defclass unportable-cl-source-file (cl-source-file) () + (:documentation + "This is for files which contain lisp-system dependent code. Until now those +are marked by a -system postfix but we could later change that to a directory per +lisp-system")) + +(defmethod perform ((op load-op) (c unportable-cl-source-file)) + (#+cmu ext:without-package-locks + #-(or cmu) progn + (call-next-method))) + +(defmethod perform ((op compile-op) (c unportable-cl-source-file)) + (#+cmu ext:without-package-locks + #-(or cmu) progn + (call-next-method))) + +(defmethod source-file-type ((c unportable-cl-source-file) (s module)) + "lisp") + + +(defun lisp-system-shortname () + #+allegro :allegro #+lispworks :lispworks #+cmu :cmucl + #+(or mcl openmcl) :mcl #+clisp :clisp #+scl :scl #+sbcl :sbcl) ;mcl/openmcl use the same directory + +(defmethod component-pathname ((component unportable-cl-source-file)) + (let ((pathname (call-next-method)) + (name (string-downcase (lisp-system-shortname)))) + (merge-pathnames + (make-pathname :directory (list :relative name)) + pathname))) + +;;;; system + +#+(and mcl (not openmcl)) (require :ansi-make-load-form) + +(defsystem acl-compat + :name "acl-compat" + :author "The acl-compat team" + :version "0.1.1" + :description + "A reimplementation of parts of the ACL API, mainly to get + AllegroServe running on various machines, but might be useful + in other projects as well." + :properties + ((("system" "author" "email") . "portableaserve-discuss(a)lists.sourceforge.net") + (("albert" "presentation" "output-dir") . "docs/") + (("albert" "presentation" "formats") . "docbook") + (("albert" "docbook" "dtd") . "/Users/Shared/DocBook/lib/docbook/docbook-dtd-412/docbookx.dtd") + (("albert" "docbook" "template") . "book")) + :components + ( + ;; packages + (:file "packages") + ;; Our stream class; support for buffering, chunking and (in the + ;; future) unified stream exceptions + #-(or lispworks (and mcl (not openmcl))) + (:file "lw-buffering" :depends-on ("packages")) + #-(or allegro (and mcl (not openmcl))) + (:legacy-cl-source-file "chunked-stream-mixin" + :depends-on ("packages" "acl-excl" + #-lispworks "lw-buffering")) + ;; Multiprocessing + #+(or mcl openmcl) (:unportable-cl-source-file "mcl-timers") + (:unportable-cl-source-file "acl-mp" + :depends-on ("packages" #+(or mcl openmcl) "mcl-timers")) + ;; Sockets, networking; TODO: de-frob this a bit + #-(or mcl openmcl) + (:unportable-cl-source-file + "acl-socket" :depends-on ("packages" "acl-excl" + #-(or allegro (and mcl (not openmcl))) "chunked-stream-mixin")) + #+(and mcl (not openmcl)) + (:unportable-cl-source-file "acl-socket-mcl" :depends-on ("packages")) + #+(and mcl (not openmcl) (not carbon-compat)) + (:unportable-cl-source-file + "mcl-stream-fix" :depends-on ("acl-socket-mcl")) + #+openmcl + (:unportable-cl-source-file + "acl-socket-openmcl" :depends-on ("packages" "chunked-stream-mixin")) + ;; Diverse macros, utility functions + #-allegro (:file "acl-excl-common" :depends-on ("packages")) + (:unportable-cl-source-file "acl-excl" :depends-on + #-allegro ("acl-excl-common") + #+allegro ("packages")) + (:unportable-cl-source-file "acl-sys" :depends-on ("packages")) + ;; SSL + #+(and ssl-available (not (or allegro mcl openmcl clisp))) + (:file "acl-ssl" :depends-on ("acl-ssl-streams" "acl-socket")) + #+(and ssl-available (not (or allegro mcl openmcl clisp))) + (:file "acl-ssl-streams" :depends-on ("packages"))) + ;; Dependencies + :depends-on (:puri + :cl-ppcre + #+sbcl :sb-bsd-sockets + #+sbcl :sb-posix + #+(and cmu (not gray-streams)) :cmucl-graystream + #+(and (or cmu lispworks) ssl-available) :cl-ssl + ) + :perform (load-op :after (op acl-compat) + (pushnew :acl-compat cl:*features*))) Added: branches/trunk-reorg/thirdparty/acl-compat/acl-excl-common.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/acl-excl-common.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,194 @@ +;;;; +;;;; ACL-COMPAT - EXCL +;;;; +;;;; This is a modified version of Chris Doubles ACL excl wrapper library +;;;; As stated in the changelogs of his original this file includes the +;;;; IF* macro placed in the public domain by John Foderaro. +;;;; See: http://www.franz.com/~jkf/ifstar.txt +;;;; + +;;;; This file was made by Rudi Schlatte to gather +;;;; not-implementation-specific parts of acl-compat in one place. + +;;;; This is the header of Chris Doubles original file. (but without Changelog) +;;;; +;;;; ACL excl wrapper library for Corman Lisp - Version 1.1 +;;;; +;;;; Copyright (C) 2000 Christopher Double. All Rights Reserved. +;;;; +;;;; License +;;;; ======= +;;;; This software is provided 'as-is', without any express or implied +;;;; warranty. In no event will the author be held liable for any damages +;;;; arising from the use of this software. +;;;; +;;;; Permission is granted to anyone to use this software for any purpose, +;;;; including commercial applications, and to alter it and redistribute +;;;; it freely, subject to the following restrictions: +;;;; +;;;; 1. The origin of this software must not be misrepresented; you must +;;;; not claim that you wrote the original software. If you use this +;;;; software in a product, an acknowledgment in the product documentation +;;;; would be appreciated but is not required. +;;;; +;;;; 2. Altered source versions must be plainly marked as such, and must +;;;; not be misrepresented as being the original software. +;;;; +;;;; 3. This notice may not be removed or altered from any source +;;;; distribution. +;;;; + +(in-package :acl-compat.excl) + +(defvar if*-keyword-list '("then" "thenret" "else" "elseif")) + +;this is not used in aserve, but is needed to use the franz xmlutils package with acl-compat +(defvar *current-case-mode* :case-insensitive-upper) + +(defmacro if* (&rest args) + (do ((xx (reverse args) (cdr xx)) + (state :init) + (elseseen nil) + (totalcol nil) + (lookat nil nil) + (col nil)) + ((null xx) + (cond ((eq state :compl) + `(cond ,@totalcol)) + (t (error "if*: illegal form ~s" args)))) + (cond ((and (symbolp (car xx)) + (member (symbol-name (car xx)) + if*-keyword-list + :test #'string-equal)) + (setq lookat (symbol-name (car xx))))) + + (cond ((eq state :init) + (cond (lookat (cond ((string-equal lookat "thenret") + (setq col nil + state :then)) + (t (error + "if*: bad keyword ~a" lookat)))) + (t (setq state :col + col nil) + (push (car xx) col)))) + ((eq state :col) + (cond (lookat + (cond ((string-equal lookat "else") + (cond (elseseen + (error + "if*: multiples elses"))) + (setq elseseen t) + (setq state :init) + (push `(t ,@col) totalcol)) + ((string-equal lookat "then") + (setq state :then)) + (t (error "if*: bad keyword ~s" + lookat)))) + (t (push (car xx) col)))) + ((eq state :then) + (cond (lookat + (error + "if*: keyword ~s at the wrong place " (car xx))) + (t (setq state :compl) + (push `(,(car xx) ,@col) totalcol)))) + ((eq state :compl) + (cond ((not (string-equal lookat "elseif")) + (error "if*: missing elseif clause "))) + (setq state :init))))) + +(defvar *initial-terminal-io* *terminal-io*) +(defvar *cl-default-special-bindings* nil) + +(defun filesys-size (stream) + (file-length stream)) + +(defun filesys-write-date (stream) + (file-write-date stream)) + +(defun frob-regexp (regexp) + "This converts from ACL regexps to Perl regexps. The escape + status of (, ) and | is toggled." + (let ((escapees '(#\) #$ #\| ))) + (with-input-from-string (in regexp) + (with-output-to-string (out) + (loop for c = (read-char in nil nil nil) + while c + do (cond ((and (char= c #\$ + (member (peek-char nil in nil nil nil) escapees)) + (setf c (read-char in))) + ((member c escapees) + (princ #\\ out))) + (princ c out)))))) + +;; TODO: a compiler macro for constant string regexps would be nice, +;; so that the create-scanner call at runtime can be evaded. +(defun match-regexp (string-or-regexp string-to-match + &key newlines-special case-fold return + (start 0) end shortest) + "Note: if a regexp compiled with compile-regexp is passed, the + options newlines-special and case-fold shouldn't be used, since + the underlying engine uses them when generating the scanner, + not when executing it." + (when shortest (error "match-regexp: shortest option not supported yet.")) + (unless end (setf end (length string-to-match))) + (let ((scanner (cl-ppcre:create-scanner (frob-regexp string-or-regexp) + :case-insensitive-mode case-fold + :single-line-mode newlines-special))) + (ecase return + (:string ; return t, list of strings + (multiple-value-bind (match regs) + (cl-ppcre:scan-to-strings scanner string-to-match + :start start :end end) + (if match + (apply #'values t match (coerce regs 'list)) + nil))) + (:index ; return (cons start end) + (multiple-value-bind (start end reg-starts reg-ends) + (cl-ppcre:scan scanner string-to-match :start start :end end) + (and start (apply #'values t (cons start end) + (map 'list #'cons reg-starts reg-ends))))) + ((nil) ; return t + (not (not (cl-ppcre:scan scanner string-to-match + :start start :end end))))))) + + +;; Caution Incompatible APIs! cl-ppcre has options case-insensitive, +;; single-line for create-scanner, ACL has it in match-regexp. +(defun compile-regexp (regexp) + "Note: Take care when using scanners compiled with this option + to not depend on options case-fold and newlines-special in match-regexp." + (cl-ppcre:create-scanner (frob-regexp regexp))) + +(defvar *current-case-mode* :case-insensitive-upper) + +(defun intern* (s len package) + (intern (subseq s 0 len) package)) + +(defmacro errorset (form &optional (announce nil) (catch-breaks nil)) + "This macro is incomplete. It was hacked to get AllegroServe +running, but the announce and catch-breaks arguments are ignored. See +documentation at +http://franz.com/support/documentation/6.1/doc/pages/operators/excl/errorset.htm +An implementation of the catch-breaks argument will necessarily be +implementation-dependent, since Ansi does not allow any +program-controlled interception of a break." + (declare (ignore announce catch-breaks)) + `(let* ((ok nil) + (results (ignore-errors + (prog1 (multiple-value-list ,form) + (setq ok t))))) + (if ok + (apply #'values t results) + nil))) + +(defmacro fast (&body forms) + `(locally (declare (optimize (speed 3) (safety 0) (debug 0))) + ,@forms)) + +#-cmu +(defun write-vector (sequence stream &key (start 0) end endian-swap) + (declare (ignore endian-swap)) + (check-type sequence (or string (array (unsigned-byte 8) 1) + (array (signed-byte 8) 1))) + (write-sequence sequence stream :start start :end end)) + Added: branches/trunk-reorg/thirdparty/acl-compat/acl-excl-corman.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/acl-excl-corman.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,233 @@ +;;;; +;;;; ACL-COMPAT - EXCL +;;;; +;;;; This is a modified version of Chris Doubles ACL excl wrapper library +;;;; As stated in the changelogs of his original this file includes the +;;;; IF* macro placed in the public domain by John Foderaro. +;;;; See: http://www.franz.com/~jkf/ifstar.txt +;;;; +;;;; It is not clear to this point if future releases will lead to a combined +;;;; effort - So you may find newer versions of *this* file at +;;;; http://www.dataheaven.de +;;;; + +;;;; This is the header of Chris Doubles original file. (but without Changelog) +;;;; +;;;; ACL excl wrapper library for Corman Lisp - Version 1.1 +;;;; +;;;; Copyright (C) 2000 Christopher Double. All Rights Reserved. +;;;; +;;;; License +;;;; ======= +;;;; This software is provided 'as-is', without any express or implied +;;;; warranty. In no event will the author be held liable for any damages +;;;; arising from the use of this software. +;;;; +;;;; Permission is granted to anyone to use this software for any purpose, +;;;; including commercial applications, and to alter it and redistribute +;;;; it freely, subject to the following restrictions: +;;;; +;;;; 1. The origin of this software must not be misrepresented; you must +;;;; not claim that you wrote the original software. If you use this +;;;; software in a product, an acknowledgment in the product documentation +;;;; would be appreciated but is not required. +;;;; +;;;; 2. Altered source versions must be plainly marked as such, and must +;;;; not be misrepresented as being the original software. +;;;; +;;;; 3. This notice may not be removed or altered from any source +;;;; distribution. +;;;; +;;;; Notes +;;;; ===== +;;;; A simple implementation of some of the EXCL package from Allegro +;;;; Common Lisp. Intended to be used for porting various ACL packages, +;;;; like AllegroServe. +;;;; +;;;; More recent versions of this software may be available at: +;;;; http://www.double.co.nz/cl +;;;; +;;;; Comments, suggestions and bug reports to the author, +;;;; Christopher Double, at: chris(a)double.co.nz + +(require 'nregex) +(require 'mp) + +(defpackage :excl + (:use :common-lisp :nregex) + (:import-from :common-lisp "FIXNUMP") + (:export + "IF*" + "*INITIAL-TERMINAL-IO*" + "*CL-DEFAULT-SPECIAL-BINDINGS*" + "FILESYS-SIZE" + "FILESYS-WRITE-DATE" + "STREAM-INPUT-FN" + "MATCH-REGEXP" + "COMPILE-REGEXP" + "*CURRENT-CASE-MODE*" + "INTERN*" + "FILESYS-TYPE" + "ERRORSET" + "ATOMICALLY" + "FAST" + "WITHOUT-PACKAGE-LOCKS" + "SOCKET-ERROR" + "RUN-SHELL-COMMAND" + "FIXNUMP" + )) + +(in-package :excl) + +(defvar if*-keyword-list '("then" "thenret" "else" "elseif")) + +(defmacro if* (&rest args) + (do ((xx (reverse args) (cdr xx)) + (state :init) + (elseseen nil) + (totalcol nil) + (lookat nil nil) + (col nil)) + ((null xx) + (cond ((eq state :compl) + `(cond ,@totalcol)) + (t (error "if*: illegal form ~s" args)))) + (cond ((and (symbolp (car xx)) + (member (symbol-name (car xx)) + if*-keyword-list + :test #'string-equal)) + (setq lookat (symbol-name (car xx))))) + + (cond ((eq state :init) + (cond (lookat (cond ((string-equal lookat "thenret") + (setq col nil + state :then)) + (t (error + "if*: bad keyword ~a" lookat)))) + (t (setq state :col + col nil) + (push (car xx) col)))) + ((eq state :col) + (cond (lookat + (cond ((string-equal lookat "else") + (cond (elseseen + (error + "if*: multiples elses"))) + (setq elseseen t) + (setq state :init) + (push `(t ,@col) totalcol)) + ((string-equal lookat "then") + (setq state :then)) + (t (error "if*: bad keyword ~s" + lookat)))) + (t (push (car xx) col)))) + ((eq state :then) + (cond (lookat + (error + "if*: keyword ~s at the wrong place " (car xx))) + (t (setq state :compl) + (push `(,(car xx) ,@col) totalcol)))) + ((eq state :compl) + (cond ((not (string-equal lookat "elseif")) + (error "if*: missing elseif clause "))) + (setq state :init))))) + +(defvar *initial-terminal-io* *terminal-io*) +(defvar *cl-default-special-bindings* nil) + +(defun filesys-size (stream) + (file-length stream)) + +(defun filesys-write-date (stream) + (file-write-date stream)) + +#+obsolete +(defun stream-input-fn (stream) + stream) + +(defmethod stream-input-fn ((stream stream)) + stream) + + +(defun match-regexp (pattern string &key (return :string)) + (let ((res (cond ((stringp pattern) + (regex pattern string)) + ((functionp pattern) (funcall pattern string)) + (t (error "Wrong type for pattern"))))) + (case return + (:string + (values-list (cons (not (null res)) + res))) + (:index (error "REGEXP: INDEX Not implemented")) + (otherwise (not (null res)))))) + +(defun compile-regexp (regexp) + (compile nil (regex-compile regexp))) + +(defvar *current-case-mode* :case-insensitive-upper) + +(defun intern* (s len package) + (intern (subseq s 0 len) package)) + +(defun filesys-type (file-or-directory-name) + (if (ccl::directory-p file-or-directory-name) + :directory + (if (probe-file file-or-directory-name) + :file + nil))) + +(defmacro errorset (form &optional (announce nil) (catch-breaks nil)) + "This macro is incomplete. It was hacked to get AllegroServe +running, but the announce and catch-breaks arguments are ignored. See +documentation at +http://franz.com/support/documentation/6.1/doc/pages/operators/excl/errorset.htm +An implementation of the catch-breaks argument will necessarily be +implementation-dependent, since Ansi does not allow any +program-controlled interception of a break." + (declare (ignore announce catch-breaks)) + `(let* ((ok nil) + (results (ignore-errors + (prog1 (multiple-value-list ,form) + (setq ok t))))) + (if ok + (apply #'values t results) + nil))) + + +(defmacro atomically (&body forms) + `(mp:without-scheduling ,@forms)) + +(defmacro fast (&body forms) + `(locally (declare (optimize (speed 3) (safety 0) (debug 0))) + ,@forms)) + +(defmacro without-package-locks (&body forms) + `(progn ,@forms)) + +(define-condition socket-error (error) + ((stream :initarg :stream) + (code :initarg :code :initform nil) + (action :initarg :action) + (identifier :initarg :identifier :initform nil)) + (:report (lambda (e s) + (with-slots (identifier code action stream) e + (format s "~S (errno ~A) occured while ~A" + (case identifier + (:connection-refused "Connection refused") + (t identifier)) + code action) + (when stream + (prin1 stream s)) + (format s "."))))) + +#| +(defun run-shell-command () + (with-open-stream (s (open-pipe "/bin/sh" + :direction :io + :buffered nil)) + (loop for var in environment + do (format stream "~A=~A~%" (car var) (cdr var))) +|# + + +(provide 'acl-excl) Added: branches/trunk-reorg/thirdparty/acl-compat/acl-mp-corman.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/acl-mp-corman.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,52 @@ +;;; This file implements the process functions for AllegroServe in Corman Lisp. + +(require 'mp) + +(defpackage :acl-compat-mp + (:use :common-lisp :mp :sys) + (:export + #:process-interrrupt + #:make-process + #:make-process-lock + #:process-add-run-reason + #:process-kill + #:process-property-list + #:process-revoke-run-reason + #:process-run-function + #:with-process-lock + #:with-timeout + #:without-scheduling + #:*current-process* + #:lock + #:process-allow-schedule + #:process-name + #:process-preset + #:process-run-reasons + #:process-wait + #:without-interrupts + )) + +(in-package :acl-compat-mp) + +; existing stuff from ccl we can reuse directly +;; The following process-property-list implementation was taken from +;; the acl-mp-scl.lisp implementation. +(defvar *process-plists* (make-hash-table :test #'eq) + "maps processes to their plists. +See the functions process-plist, (setf process-plist).") + +(defun process-property-list (process) + (gethash process *process-plists*)) + +(defun (setf process-property-list) (new-value process) + (setf (gethash process *process-plists*) new-value)) + +;; Dummy implementation of process-wait +(defun process-wait (whostate function &rest args) + "This function suspends the current process (the value of sys:*current-process*) + until applying function to arguments yields true. The whostate argument must be a + string which temporarily replaces the process' whostate for the duration of the wait. + This function returns nil." + (loop until (apply function args) do (sleep 0)) + nil) + Added: branches/trunk-reorg/thirdparty/acl-compat/acl-mp-package.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/acl-mp-package.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,80 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: CL-USER; -*- +;;;; ; +;;;; (c) 2001 by Jochen Schmidt. +;;;; +;;;; File: acl-mp-package.lisp +;;;; Revision: 1.0.0 +;;;; Description: Package definition for ACL-COMPAT-MP +;;;; Date: 02.02.2002 +;;;; Authors: Jochen Schmidt +;;;; Tel: (+49 9 11) 47 20 603 +;;;; Email: jsc(a)dataheaven.de +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; 2. 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 "AS IS" AND THERE ARE NEITHER +;;;; EXPRESSED NOR IMPLIED WARRANTIES - THIS INCLUDES, BUT +;;;; IS NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY +;;;; AND FITNESS FOR A PARTICULAR PURPOSE.IN NO WAY ARE THE +;;;; AUTHORS 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) +;;;; +;;;; For further details contact the authors of this software. +;;;; +;;;; Jochen Schmidt +;;;; Zuckmantelstr. 11 +;;;; 91616 Neusitz +;;;; GERMANY +;;;; +;;;; + +(defpackage :acl-compat-mp + (:use :common-lisp) + (:export + #:*current-process* ;* + #:process-kill ;* + #:process-preset ;* + #:process-name ;* + + #:process-wait-function + #:process-run-reasons + #:process-arrest-reasons + #:process-whostate + #:without-interrupts + #:process-wait + #:process-enable + #:process-disable + #:process-reset + #:process-interrupt + + #:process-run-function ;* + #:process-property-list ;* + #:without-scheduling ;* + #:process-allow-schedule ;* + #:make-process ;* + #:process-add-run-reason ;* + #:process-revoke-run-reason ;* + #:process-add-arrest-reason ;* + #:process-revoke-arrest-reason ;* + #:process-allow-schedule ;* + #:with-timeout ;* + #:make-process-lock ;* + #:with-process-lock ;* + #:process-active-p ; required by webactions + #:current-process + #:process-name-to-process + #:process-wait-with-timeout + #:wait-for-input-available + ) + (:nicknames :acl-mp)) + +;; * marked ones are used in Portable Allegroserve Added: branches/trunk-reorg/thirdparty/acl-compat/acl-socket-corman.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/acl-socket-corman.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,194 @@ +;;;; ACL socket wrapper library for Corman Lisp - Version 1.1 +;;;; +;;;; Copyright (C) 2000 Christopher Double. All Rights Reserved. +;;;; +;;;; License +;;;; ======= +;;;; This software is provided 'as-is', without any express or implied +;;;; warranty. In no event will the author be held liable for any damages +;;;; arising from the use of this software. +;;;; +;;;; Permission is granted to anyone to use this software for any purpose, +;;;; including commercial applications, and to alter it and redistribute +;;;; it freely, subject to the following restrictions: +;;;; +;;;; 1. The origin of this software must not be misrepresented; you must +;;;; not claim that you wrote the original software. If you use this +;;;; software in a product, an acknowledgment in the product documentation +;;;; would be appreciated but is not required. +;;;; +;;;; 2. Altered source versions must be plainly marked as such, and must +;;;; not be misrepresented as being the original software. +;;;; +;;;; 3. This notice may not be removed or altered from any source +;;;; distribution. +;;;; +;;;; Notes +;;;; ===== +;;;; A simple wrapper around the SOCKETS package to present an interface +;;;; similar to the Allegro Common Lisp SOCKET package. Based on a package +;;;; by David Bakhash for LispWorks. For documentation on the ACL SOCKET +;;;; package see: +;;;; +;;;; http://www.franz.com/support/documentation/5.0.1/doc/cl/socket.htm +;;;; +;;;; More recent versions of this software may be available at: +;;;; http://www.double.co.nz/cl +;;;; +;;;; Comments, suggestions and bug reports to the author, +;;;; Christopher Double, at: chris(a)double.co.nz +;;;; +;;;; 17/09/2000 - 1.0 +;;;; Initial release. +;;;; +;;;; 20/09/2000 - 1.1 +;;;; Added SOCKET-CONTROL function. +;;;; +;;;; 27/02/2001 - 1.2 +;;;; Added ability to create SSL sockets. Doesn't use +;;;; same interface as Allegro 6 - need to look into +;;;; how that works. +;;;; +;;;; 03/01/2003 - 1.3 +;;;; Added to PortableAllegroServe. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :sockets) + (require :ssl-sockets)) + +(sockets:start-sockets) +(ssl-sockets:start-ssl-sockets) + +(defpackage socket + (:use "COMMON-LISP") + (:export + "MAKE-SOCKET" + "ACCEPT-CONNECTION" + "DOTTED-TO-IPADDR" + "IPADDR-TO-DOTTED" + "IPADDR-TO-HOSTNAME" + "LOOKUP-HOSTNAME" + "REMOTE-HOST" + "LOCAL-HOST" + "LOCAL-PORT" + "SOCKET-CONTROL" + )) + +(in-package :socket) + +(defmethod accept-connection ((server-socket sockets::server-socket) + &key (wait t)) + (unless wait + (error "WAIT keyword to ACCEPT-CONNECTION not implemented.")) + (sockets:make-socket-stream + (sockets:accept-socket server-socket))) + +(defun make-socket (&key + (remote-host "0.0.0.0") ;;localhost? + type + local-port + remote-port + (connect :active) + (format :text) + ssl + &allow-other-keys) + (check-type remote-host string) + (when (eq type :datagram) + (error ":DATAGRAM keyword to MAKE-SOCKET not implemented.")) + (when (eq format :binary) + (warn ":BINARY keyword to MAKE-SOCKET partially implemented.")) + + (ecase connect + (:passive + (sockets:make-server-socket + :host remote-host + :port local-port)) + (:active + (sockets:make-socket-stream + (if ssl + (ssl-sockets:make-client-ssl-socket + :host remote-host + :port remote-port) + (sockets:make-client-socket + :host remote-host + :port remote-port)))))) + + +(defun dotted-to-ipaddr (dotted &key errorp) + (when errorp + (warn ":ERRORP keyword to DOTTED-TO-IPADDR not supported.")) + (sockets:host-to-ipaddr dotted)) + +(defun ipaddr-to-dotted (ipaddr &key values) + (when values + (error ":VALUES keyword to IPADDR-TO-DOTTED not supported.")) + (sockets:ipaddr-to-dotted ipaddr)) + +(defun ipaddr-to-hostname (ipaddr &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword to IPADDR-TO-HOSTNAME not supported.")) + (sockets:ipaddr-to-name ipaddr)) + +(defun lookup-hostname (host &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword to IPADDR-TO-HOSTNAME not supported.")) + (if (stringp host) + (sockets:host-to-ipaddr host) + (dotted-to-ipaddr (ipaddr-to-dotted host)))) + +(defun remote-host (socket-or-stream) + (let ((socket (if (typep socket-or-stream 'sockets:base-socket) + socket-or-stream + (sockets:stream-socket-handle socket-or-stream)))) + (sockets::remote-socket-ipaddr socket))) + +(defun local-host (socket-or-stream) + (let ((socket (if (typep socket-or-stream 'sockets:base-socket) + socket-or-stream + (sockets:stream-socket-handle socket-or-stream)))) + (if (not (typep socket 'sockets:local-socket)) + 16777343 + (sockets::socket-host-ipaddr socket)))) + +(defun local-port (socket-or-stream) + (let ((socket (if (typep socket-or-stream 'sockets:base-socket) + socket-or-stream + (sockets:stream-socket-handle socket-or-stream)))) + (sockets:socket-port socket))) + +(defun socket-control (stream &key output-chunking output-chunking-eof input-chunking) + (declare (ignore stream output-chunking output-chunking-eof input-chunking)) + (warn "SOCKET-CONTROL function not implemented.")) + +;; Some workarounds to get combined text/binary socket streams working +(defvar old-read-byte #'cl::read-byte) + +(defun new-read-byte (stream &optional (eof-error-p t) (eof-value nil)) + "Replacement for Corman Lisp READ-BYTE to work with socket streams correctly." + (if (eq (cl::stream-subclass stream) 'sockets::socket-stream) + (char-int (read-char stream eof-error-p eof-value)) + (funcall old-read-byte stream eof-error-p eof-value))) + +(setf (symbol-function 'common-lisp::read-byte) #'new-read-byte) + +(in-package :cl) + +(defun write-sequence (sequence stream &key start end) + (let ((element-type (stream-element-type stream)) + (start (if start start 0)) + (end (if end end (length sequence)))) + (if (eq element-type 'character) + (do ((n start (+ n 1))) + ((= n end)) + (write-char (if (typep (elt sequence n) 'number) (ccl:int-char (elt sequence n)) (elt sequence n)) stream)) + (do ((n start (+ n 1))) + ((= n end)) + (write-byte (elt sequence n) stream)))) ;; recoded to avoid LOOP, because it isn't loaded yet + ;(loop for n from start below end do + ; (write-char (elt sequence n) stream)) + ;(loop for n from start below end do + ; (write-byte (elt sequence n) stream)) + (force-output stream)) + +(provide 'acl-socket) + Added: branches/trunk-reorg/thirdparty/acl-compat/acl-ssl-streams.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/acl-ssl-streams.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,293 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: CL-USER; -*- +;;; +;;; Filename: gray-streams-integration.lisp +;;; Author: Jochen Schmidt <jsc(a)dataheaven.de> +;;; Description: Integrate ssl-sockets with the lisp +;;; stream system using gray-streams. +;;; + +(in-package :ssl) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Gray Streams integration ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass ssl-stream-mixin () + ((ssl-socket :accessor ssl-socket :initarg :ssl-socket))) + +(defclass binary-ssl-stream + (ssl-stream-mixin + gray-stream:fundamental-binary-input-stream + gray-stream:fundamental-binary-output-stream) + ()) + +(defclass character-ssl-stream + (ssl-stream-mixin + gray-stream:fundamental-character-input-stream + gray-stream:fundamental-character-output-stream) + ()) + +(defmethod #-cormanlisp gray-stream::stream-element-type #+cormanlisp gray-stream::stream-stream-element-type ((socket-stream binary-ssl-stream)) + '(unsigned-byte 8)) + +(defmethod #-cormanlisp gray-stream::stream-element-type #+cormanlisp gray-stream::stream-stream-element-type ((socket-stream character-ssl-stream)) + 'character) + +(defmethod gray-stream:stream-line-column ((socket-stream character-ssl-stream)) + nil) + +(defmethod gray-stream:stream-line-column ((socket-stream binary-ssl-stream)) + nil) + +(defmethod gray-stream:stream-listen ((socket-stream ssl-stream-mixin)) + (with-slots (ssl-socket) socket-stream + (> (ssl-internal:ssl-pending (ssl-internal:ssl-socket-handle ssl-socket)) 0))) + +(defmethod gray-stream:stream-read-byte ((socket-stream binary-ssl-stream)) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-read-byte ssl-socket))) + +(defmethod gray-stream:stream-write-byte ((socket-stream binary-ssl-stream) byte) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-write-byte byte ssl-socket))) + +#| +(defmethod gray-stream:stream-read-char ((socket-stream character-ssl-stream)) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-read-char ssl-socket))) + +(defmethod gray-stream:stream-read-char ((socket-stream binary-ssl-stream)) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-read-char ssl-socket))) +|# + +; Bivalent +(defmethod gray-stream:stream-read-char ((socket-stream ssl-stream-mixin)) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-read-char ssl-socket))) + + +(defmethod gray-stream:stream-read-char-no-hang ((socket-stream character-ssl-stream)) + (when (listen socket-stream) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-read-char ssl-socket)))) + +#| +(defmethod gray-stream:stream-write-char ((socket-stream character-ssl-stream) char) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-write-char char ssl-socket))) + +(defmethod gray-stream:stream-write-char ((socket-stream binary-ssl-stream) char) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-write-char char ssl-socket))) +|# + +; Bivalent +(defmethod gray-stream:stream-write-char ((socket-stream ssl-stream-mixin) char) + (with-slots (ssl-socket) socket-stream + (ssl-internal:ssl-socket-write-char char ssl-socket))) + + + +; Bivalent +(defmethod gray-stream:stream-force-output ((socket-stream ssl-stream-mixin)) + (with-slots (ssl-socket) socket-stream + (ssl-internal:flush-output-buffer ssl-socket))) + +(defmethod gray-stream:stream-finish-output ((socket-stream ssl-stream-mixin)) + (with-slots (ssl-socket) socket-stream + (ssl-internal:flush-output-buffer ssl-socket))) + +(defmethod gray-stream:stream-clear-output ((socket-stream ssl-stream-mixin)) + (with-slots (ssl-socket) socket-stream + (with-slots (ssl-internal::output-offset) ssl-socket + (setf ssl-internal::output-offset 0)))) + +(defmethod gray-stream:stream-clear-input ((socket-stream ssl-stream-mixin)) + (with-slots (ssl-socket) socket-stream + (with-slots (ssl-internal::input-avail ssl-internal::input-offset) ssl-socket + (setf ssl-internal::input-avail 0) + (setf ssl-internal::input-offset 0)))) + +(defmethod #-cormanlisp common-lisp:close #+cormanlisp gray-stream:stream-close ((socket-stream ssl-stream-mixin) &key abort) + (with-slots (ssl-socket) socket-stream + (unless abort + (ssl-internal:flush-output-buffer ssl-socket)) + (ssl-internal:close-ssl-socket ssl-socket))) + +#| +(defmethod gray-stream:stream-force-output ((socket-stream character-ssl-stream)) + (with-slots (ssl-socket) socket-stream + (ssl-internal:flush-output-buffer ssl-socket))) + +(defmethod gray-stream:stream-finish-output ((socket-stream character-ssl-stream)) + (with-slots (ssl-socket) socket-stream + (ssl-internal:flush-output-buffer ssl-socket))) + +(defmethod gray-stream:stream-clear-output ((socket-stream character-ssl-stream)) + (with-slots (ssl-socket) socket-stream + (with-slots (ssl-internal::output-offset) ssl-socket + (setf ssl-internal::output-offset 0)))) + +(defmethod gray-stream:stream-clear-input ((socket-stream character-ssl-stream)) + (with-slots (ssl-socket) socket-stream + (with-slots (ssl-internal::input-avail ssl-internal::input-offset) ssl-socket + (setf ssl-internal::input-avail 0) + (setf ssl-internal::input-offset 0)))) + +(defmethod gray-stream:stream-read-sequence ((socket-stream character-ssl-stream) sequence start end) + (let* ((len (length sequence)) + (chars (- (min (or end len) len) start))) + ;(format t "Read ~A chars from index ~A on.~%" chars start) (force-output t) + (loop for i upfrom start + repeat chars + for char = (progn ;(format t "Read char on index ~A~%" i) + ;(force-output t) + (let ((c (gray-streams:stream-read-char socket-stream))) + ;(format t "The element read was ~A~%" c) + c)) + if (eq char :eof) do (progn ;(format t "premature return on index ~A~%" i) + ;(force-output t) + (return-from gray-streams:stream-read-sequence i)) + do (setf (elt sequence i) char)) + ;(format t "Normal return on index ~A~%" (+ start chars)) (force-output t) + (+ start chars))) + +|# + +;; +;; Why this argument ordering in CMUCL? LW has (stream sequence start end) +;; It would be interesting to know why it is a particular good idea to +;; reinvent APIs every second day in an incompatible way.... *grrr* +;; + +#+cmu +(defmethod gray-stream:stream-read-sequence ((socket-stream character-ssl-stream) (sequence sequence) &optional start end) + (let* ((len (length sequence)) + (chars (- (min (or end len) len) start))) + (loop for i upfrom start + repeat chars + for char = (gray-stream:stream-read-char socket-stream) + if (eq char :eof) do (return-from gray-stream:stream-read-sequence i) + do (setf (elt sequence i) char)) + (+ start chars))) + +#+cmu +(defmethod gray-stream:stream-read-sequence ((socket-stream binary-ssl-stream) (sequence sequence) &optional start end) + (let* ((len (length sequence)) + (chars (- (min (or end len) len) start))) + (loop for i upfrom start + repeat chars + for char = (gray-stream:stream-read-byte socket-stream) + if (eq char :eof) do (return-from gray-stream:stream-read-sequence i) + do (setf (elt sequence i) char)) + (+ start chars))) + +#| +(defmethod gray-stream:stream-read-sequence ((socket-stream binary-ssl-stream) sequence start end) + (let* ((len (length sequence)) + (chars (- (min (or end len) len) start))) + ;(format t "Read ~A chars from index ~A on.~%" chars start) (force-output t) + (loop for i upfrom start + repeat chars + for char = (progn ;(format t "Read char on index ~A~%" i) + ;(force-output t) + (let ((c (gray-streams:stream-read-byte socket-stream))) + ;(format t "The element read was ~A~%" c) + c)) + if (eq char :eof) do (progn ;(format t "premature return on index ~A~%" i) + ;(force-output t) + (return-from gray-streams:stream-read-sequence i)) + do (setf (elt sequence i) char)) + ;(format t "Normal return on index ~A~%" (+ start chars)) (force-output t) + (+ start chars))) +|# + +#| Alternative implementation? +(defmethod stream:stream-read-sequence ((socket-stream character-ssl-stream) sequence start end) + (let* ((len (length sequence)) + (chars (- (min (or end len) len) start))) + (format t "Read ~A chars from index ~A on.~%" chars start) (force-output t) + (loop for i upfrom start + repeat chars + for char = (progn (format t "Read char on index ~A~%" i) + (force-output t) + (let ((c (stream:stream-read-char socket-stream))) + (format t "The element read was ~A~%" c) c)) + if (eq char :eof) do (progn (format t "premature return on index ~A~%" i) + (force-output t) + (return-from stream:stream-read-sequence i)) + do (setf (elt sequence i) char)) + (format t "Normal return on index ~A~%" (+ start chars)) (force-output t) + (+ start chars))) +|# + +#| +(defmethod common-lisp:close ((socket-stream character-ssl-stream) &key abort) + (with-slots (ssl-socket) socket-stream + (unless abort + (ssl-internal:flush-output-buffer ssl-socket)) + (ssl-internal:close-ssl-socket ssl-socket))) +|# + +#+lispworks +(declaim (inline %reader-function-for-sequence)) +#+lispworks +(defun %reader-function-for-sequence (sequence) + (typecase sequence + (string #'read-char) + ((array unsigned-byte (*)) #'read-byte) + ((array signed-byte (*)) #'read-byte) + (otherwise #'read-byte))) + +#+lispworks +(declaim (inline %writer-function-for-sequence)) +#+lispworks +(defun %writer-function-for-sequence (sequence) + (typecase sequence + (string #'write-char) + ((array unsigned-byte (*)) #'write-byte) + ((array signed-byte (*)) #'write-byte) + (otherwise #'write-byte))) + +;; Bivalent socket support for READ-SEQUENCE / WRITE-SEQUENCE +#+lispworks +(defmethod gray-stream:stream-read-sequence ((stream ssl-stream-mixin) sequence start end) + (stream::read-elements stream sequence start end (%reader-function-for-sequence sequence))) + +#+lispworks +(defmethod gray-stream:stream-write-sequence ((stream ssl-stream-mixin) sequence start end) + (stream::write-elements stream sequence start end (typecase sequence + (string t) + ((array unsigned-byte (*)) nil) + ((array signed-byte (*)) nil) + (otherwise nil)))) + +#+lispworks +(in-package :acl-socket) + +#+lispworks +(defmethod remote-host ((socket ssl::ssl-stream-mixin)) + (comm:get-socket-peer-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket)))) + +#+lispworks +(defmethod remote-port ((socket ssl::ssl-stream-mixin)) + (multiple-value-bind (host port) + (comm:get-socket-peer-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket))) + (declare (ignore host)) + port)) + +#+lispworks +(defmethod local-host ((socket ssl::ssl-stream-mixin)) + (multiple-value-bind (host port) + (comm:get-socket-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket))) + (declare (ignore port)) + host)) + +#+lispworks +(defmethod local-port ((socket ssl::ssl-stream-mixin)) + (multiple-value-bind (host port) + (comm:get-socket-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket))) + (declare (ignore host)) + port)) + Added: branches/trunk-reorg/thirdparty/acl-compat/acl-ssl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/acl-ssl.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,58 @@ +(in-package :ssl) +;;;;;;;;;;;;;;;;;;;;; +;;; ACL style API ;;; +;;;;;;;;;;;;;;;;;;;;; + +(defmethod make-ssl-client-stream ((socket integer) &rest options) + (destructuring-bind (&key (format :binary)) options + (when (minusp socket) + (error "not a proper socket descriptor")) + (let ((ssl-socket (make-instance 'ssl-internal:ssl-client-socket :fd socket))) + (case format + (:binary (make-instance 'binary-ssl-stream + :ssl-socket ssl-socket)) + (:text (make-instance 'character-ssl-stream + :ssl-socket ssl-socket)) + (otherwise (error "Unknown ssl-stream format")))))) + +#+lispworks +(defmethod make-ssl-client-stream ((lw-socket-stream comm:socket-stream) &rest options) + (apply #'make-ssl-client-stream (comm:socket-stream-socket lw-socket-stream) options)) + +#+cormanlisp +(defmethod make-ssl-client-stream (stream &rest options) + (apply #'make-ssl-client-stream (sockets:socket-descriptor (cl::stream-handle stream)) options)) + +(defmethod make-ssl-server-stream ((socket integer) &rest options) + (destructuring-bind (&key certificate key other-certificates (format :binary)) options + (when (minusp socket) + (error "not a proper socket descriptor")) + (let ((ssl-socket (make-instance 'ssl-internal:ssl-server-socket + :fd socket + :rsa-privatekey-file (or key certificate) + :certificate-file (or certificate key)))) + (case format + (:binary (make-instance 'binary-ssl-stream + :ssl-socket ssl-socket)) + (:text (make-instance 'character-ssl-stream + :ssl-socket ssl-socket)) + (otherwise (error "Unknown ssl-stream format")))))) + +(defmethod make-ssl-server-stream ((socket ssl-stream-mixin) &rest options) + (warn "SSL socket ~A reused" socket) + socket) + +#+lispworks +(defmethod make-ssl-server-stream ((lw-socket-stream comm:socket-stream) &rest options) + (apply #'make-ssl-server-stream (comm:socket-stream-socket lw-socket-stream) options)) + + +#+ignore +(defmethod make-ssl-server-stream ((acl-socket acl-socket::server-socket) &rest options) + (apply #'make-ssl-server-stream + (comm::get-fd-from-socket (acl-socket::passive-socket acl-socket)) options)) + +#+ignore +(defmethod make-ssl-server-stream ((lw-socket-stream acl-socket::chunked-socket-stream) &rest options) + (apply #'make-ssl-server-stream (comm:socket-stream-socket lw-socket-stream) options)) + Added: branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-excl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-excl.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,3 @@ +;;;; ACL-COMPAT - EXCL +;;;; +;;;; Nothing needs to be done Added: branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-mp.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-mp.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,3 @@ +;;; This file implements the process functions for AllegroServe in MCL. + +(in-package :acl-compat.mp) Added: branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-socket.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-socket.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,6 @@ +;;; Allegro layer for ACL sockets. +;;; +(in-package :acl-compat.socket) + + + Added: branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-sys.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-sys.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,4 @@ +;;; Allegro System Package Compatibility file + +;;; Nothing to do +(in-package :acl-compat.system) Added: branches/trunk-reorg/thirdparty/acl-compat/chunked-stream-mixin.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/chunked-stream-mixin.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,275 @@ +;;;; ; +;;;; (c) 2002 by Jochen Schmidt. +;;;; +;;;; File: chunked-stream-mixin.lisp +;;;; Revision: 0.1 +;;;; Description: ACL style HTTP1.1 I/O chunking +;;;; Date: 08.04.2002 +;;;; Authors: Jochen Schmidt +;;;; Tel: (+49 9 11) 47 20 603 +;;;; Email: jsc(a)dataheaven.de +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; 2. 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 "AS IS" AND THERE ARE NEITHER +;;;; EXPRESSED NOR IMPLIED WARRANTIES - THIS INCLUDES, BUT +;;;; IS NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY +;;;; AND FITNESS FOR A PARTICULAR PURPOSE.IN NO WAY ARE THE +;;;; AUTHORS 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) +;;;; +;;;; For further details contact the authors of this software. +;;;; +;;;; Jochen Schmidt +;;;; Zuckmantelstr. 11 +;;;; 91616 Neusitz +;;;; GERMANY +;;;; +;;;; Nuernberg, 08.Apr.2002 Jochen Schmidt +;;;; + +(in-package :de.dataheaven.chunked-stream-mixin) + +(defun buffer-ref (buffer index) + #+lispworks (schar buffer index) + #-lispworks (aref buffer index)) + +(defun (setf buffer-ref) (new-value buffer index) + #-lispworks (setf (aref buffer index) (char-code new-value)) + #+lispworks (setf (schar buffer index) new-value)) + +(defclass chunked-stream-mixin () + ((output-chunking-p :initform nil :accessor output-chunking-p) + (chunk-input-avail :initform nil + :documentation + "Number of octets of the current chunk that are +not yet read into the buffer, or nil if input chunking is disabled") + (real-input-limit :initform 0 + :documentation + "Index of last octet read into buffer +(input-limit points to index of last octet in the current chunk)"))) + +(defgeneric input-chunking-p (stream)) +(defmethod input-chunking-p ((stream chunked-stream-mixin)) + (not (null (slot-value stream 'chunk-input-avail)))) + +(defgeneric (setf input-chunking-p) (new-value stream)) +(defmethod (setf input-chunking-p) (new-value (stream chunked-stream-mixin)) + (setf (slot-value stream 'chunk-input-avail) (and new-value 0))) + +(define-condition acl-compat.excl::socket-chunking-end-of-file (condition) + ((acl-compat.excl::format-arguments :initform nil :initarg :format-arguments) + (acl-compat.excl::format-control :initform "A chunking end of file occured" + :initarg :format-control))) + + +;;;;;;;;;;;;;;;;;;;;;; +;;; Input chunking ;;; +;;;;;;;;;;;;;;;;;;;;;; + +;; Input chunking is not tested so far! + +(defgeneric initialize-input-chunking (stream)) +(defmethod initialize-input-chunking ((stream chunked-stream-mixin)) + "This method initializes input chunking. The real-input-limit is nil +in the beginnings because it got not saved yet. Chunk-input-avail is +obviously 0 because no chunk-data got read so far." + (gray-stream:with-stream-input-buffer (input-buffer input-index input-limit) + stream + (with-slots (real-input-limit chunk-input-avail) stream + (setf + ;; Bytes read from stream (valid data in buffer up to here) + real-input-limit input-limit + ;; Bytes available in current chunk block after buffer contents + ;; runs out (trivially zero before first chunk block read) + chunk-input-avail 0 + ;; Last buffer position that can be read before new data has to + ;; be fetched from stream (we must begin with parsing a chunk + ;; immediately; hence set to a value that guarantees this) + input-limit 0 ; or input-index? + )))) + +;; Lispworks fix by Edi Weitz (paserve-help 2003-11-28) +#+lispworks +(defmacro %with-stream-input-buffer ((input-buffer input-index input-limit) stream &body body) + `(with-slots ((,input-buffer stream::input-buffer) + (,input-index stream::input-index) + (,input-limit stream::input-limit)) + (slot-value ,stream 'stream::buffer-state) + ,@body)) + +(defmethod gray-stream:stream-fill-buffer ((stream chunked-stream-mixin)) + "Refill buffer from stream." + ;; STREAM-FILL-BUFFER gets called when the input-buffer contains no + ;; more data (the index is bigger than the limit). We call out to + ;; the real buffer filling mechanism by calling the next specialized + ;; method. This method is responsible to update the buffer state in + ;; coordination with the chunk-header. + (with-slots (chunk-input-avail real-input-limit) stream + (#-lispworks gray-stream:with-stream-input-buffer + #+lispworks %with-stream-input-buffer + (input-buffer input-index input-limit) stream + (labels + ((pop-char () + (when (and (>= input-index input-limit) ; need new data + (not (call-next-method))) ; couldn't get it + (error "Unexpected end-of-file while reading chunk block")) + (prog1 #-lispworks (code-char (buffer-ref input-buffer input-index)) + #+lispworks (buffer-ref input-buffer input-index) + (incf input-index))) + (read-chunk-header () + (let ((chunk-length 0)) + (tagbody + initial-crlf (let ((char (pop-char))) + (cond ((digit-char-p char 16) + (decf input-index) ; unread char + (go chunk-size)) + ((eq #\Return char) + (if (eq (pop-char) #\Linefeed) + (go chunk-size) + (error "End of chunk-header corrupted: Expected Linefeed"))) + (t (error "End of chunk-header corrupted: Expected Carriage Return or a digit")))) + + chunk-size (let ((char (pop-char))) + (cond ((digit-char-p char 16) + (setf chunk-length + (+ (* 16 chunk-length) + (digit-char-p char 16))) + (go chunk-size)) + (t (decf input-index) ; unread char + (go skip-rest)))) + + skip-rest (if (eq #\Return (pop-char)) + (go check-linefeed) + (go skip-rest)) + + check-linefeed (let ((char (pop-char))) + (case char + (#\Linefeed (go accept)) + (t (error "End of chunk-header corrupted: LF expected, ~A read." char)))) + + accept) + chunk-length))) + + (cond ((not (input-chunking-p stream)) + ;; Chunking not active; just fill buffer normally + (call-next-method)) + ((zerop chunk-input-avail) + ;; We are at the beginning of a new chunk. + (when real-input-limit (setf input-limit real-input-limit)) + (let* ((chunk-length (read-chunk-header)) + (end-of-chunk (+ input-index chunk-length))) + (if (zerop chunk-length) + ;; rfc2616 indicates that input chunking is + ;; turned off after zero-length chunk is read + ;; (see section 19.4.6) -- turn off chunking + (progn (signal 'acl-compat.excl::socket-chunking-end-of-file + :format-arguments stream) + (setf (input-chunking-p stream) nil) + ;; TODO: whoever handles + ;; socket-chunking-end-of-file (client.cl + ;; in AllegroServe's case) should read the + ;; trailer (see section 3.6). All we can + ;; reasonably do here is turn off + ;; chunking, or throw information away. + ) + ;; Now set up stream attributes so that read methods + ;; call refill-buffer both at end of chunk and end of + ;; buffer + (progn + (setf real-input-limit input-limit + input-limit (min real-input-limit end-of-chunk) + chunk-input-avail (max 0 (- end-of-chunk + real-input-limit))) + input-limit)))) + (t + ;; We are in the middle of a chunk; re-fill buffer + (if (call-next-method) + (progn + (setf real-input-limit input-limit) + (setf input-limit + (min real-input-limit chunk-input-avail)) + (setf chunk-input-avail + (max 0 (- chunk-input-avail real-input-limit))) + input-limit) + (error "Unexpected end-of-file in the middle of a chunk")))))))) + + +;;;;;;;;;;;;;;;;;;;;;;; +;;; Output chunking ;;; +;;;;;;;;;;;;;;;;;;;;;;; + +;; This constant is the amount of bytes the system reserves for the chunk-header +;; It is calculated as 4 bytes for the chunk-size in hexadecimal digits and a CR followed +;; by a LF +(defconstant +chunk-header-buffer-offset+ 6) + +(defgeneric initialize-output-chunking (stream)) +(defmethod initialize-output-chunking ((stream chunked-stream-mixin)) + "This method initializes output chunking. Actual contents in the output-buffer + get flushed first. A chunk has a header at the start and a CRLF at the end. + The header is the length of the (data) content in the chunk as a string in hexadecimal + digits and a trailing CRLF before the real content begins. We assume that the content + of a chunk is never bigger than #xFFFF and therefore reserve 6 bytes at the beginning + of the buffer for the header. We reduce the buffer limit by 2 so that we have always + room left in the buffer to attach a CRLF." + (unless (output-chunking-p stream) + (force-output stream) + (gray-stream:with-stream-output-buffer (buffer index limit) stream + (setf index +chunk-header-buffer-offset+) + (setf (buffer-ref buffer (- +chunk-header-buffer-offset+ 2)) #\Return + (buffer-ref buffer (1- +chunk-header-buffer-offset+)) #\Linefeed) + (decf limit 2) + (setf (output-chunking-p stream) t)))) + +(defmethod gray-stream:stream-flush-buffer ((stream chunked-stream-mixin)) + "When there is pending content in the output-buffer then compute the chunk-header and flush + the buffer" + (if (output-chunking-p stream) + (gray-stream:with-stream-output-buffer (output-buffer output-index output-limit) stream + (when (> output-index +chunk-header-buffer-offset+) + (let* ((chunk-header (format nil "~X" (- output-index +chunk-header-buffer-offset+))) + (start (- +chunk-header-buffer-offset+ 2 (length chunk-header)))) + (loop for c across chunk-header + for i upfrom start + do (setf (buffer-ref output-buffer i) c)) + (setf (buffer-ref output-buffer output-index) #\Return + (buffer-ref output-buffer (1+ output-index)) #\Linefeed) + (gray-stream:stream-write-buffer stream output-buffer start (+ output-index 2)) + (setf output-index +chunk-header-buffer-offset+)))) + (call-next-method))) + + +(defmethod close ((stream chunked-stream-mixin) &key abort) + (unless abort + (disable-output-chunking stream)) + (call-next-method)) + + +(defgeneric disable-output-chunking (stream)) +(defmethod disable-output-chunking ((stream chunked-stream-mixin)) + "When we disable chunking we first try to write out a last pending chunk and after that + reset the buffer-state to normal mode. To end the game we write out a chunk-header with + a chunk-size of zero to notify the peer that chunking ends." + (when (output-chunking-p stream) + (force-output stream) + (gray-stream:with-stream-output-buffer (buffer index limit) stream + (setf index 0) + (incf limit 2)) + (setf (output-chunking-p stream) nil + (input-chunking-p stream) nil) + (format stream "0~A~A~A~A" #\Return #\Linefeed #\Return #\Linefeed) + (force-output stream))) + + + + Added: branches/trunk-reorg/thirdparty/acl-compat/chunked.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/chunked.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,211 @@ +;;; +;;; Streams with support for "chunked" transfer coding. This module +;;; emulates the support for chunking found in Allegro Common Lisp's +;;; streams. See RFC 2616 for a description of the "chunked" transfer +;;; coding. +;;; +;;; TODO: +;;; - + +(defpackage :com.ljosa.chunked + (:use :common-lisp #+LISPWORKS :stream) + (:export :chunked-mixin :make-chunked-stream :*buffer-size* + :output-chunking :input-chunking :close-chunk)) + +(in-package :com.ljosa.chunked) + +(defparameter *buffer-size* 1024 "Maximum chunk size") + +(defvar *recursive* nil) + +(defclass chunked-mixin () + ((output-chunking :initform nil :accessor output-chunking) + (input-chunking :initform nil :accessor input-chunking) + (output-buffer) + (remaining-input :initform nil))) + +(defmethod shared-initialize :after ((stream chunked-mixin) slots-for-initform + &rest initargs) + (declare (ignore initargs slots-for-initform)) + (with-slots (output-buffer) stream + (setf output-buffer (make-array (list *buffer-size*) + :element-type 'unsigned-byte + :fill-pointer 0)))) + +(define-condition excl::socket-chunking-end-of-file (condition) + ((excl::format-arguments :initform nil) + (excl::format-control :initform "~1@<The stream ~s had a chunking end of file~:@>"))) + +;; (defmethod stream-element-type ((stream chunked-mixin)) +;; (call-next-method)) + +(defun read-chunk-header (stream &aux (x 0) (*recursive* t)) + (tagbody + s0 (let ((char (read-char stream))) + (cond ((digit-char-p char 16) (setf x (+ (* 16 x) (digit-char-p char 16))) + (go s0)) + ((eq #\; char) (go s1)) + ((eq #\; char) (go s2)) + (t (error "Parse error in state s0: ~S." char)))) + s1 (if (eq #\Return (read-char stream)) + (go s2) + (go s1)) + s2 (let ((char (read-char stream))) + (case char + (#\Linefeed (go accept)) + (t (error "Parse error in state s2: ~S." char)))) + accept) + x) + +;; FIXME: What do do when the chunked input stream can't be parsed? + +(defun gobble-crlf (stream &aux (*recursive* t)) + (flet ((expect (expected-char) + (let ((char (read-char stream))) + (unless (eq expected-char char) + (error "Expected ~C, got ~C." expected-char char))))) + (expect #\Return) + (expect #\Linefeed))) + +(defmethod stream-read-char ((stream chunked-mixin)) + (with-slots (input-chunking remaining-input output-chunking) stream + (cond (*recursive* (call-next-method)) + ((not input-chunking) (call-next-method)) + ((not remaining-input) (handler-case + (progn + (setf remaining-input (read-chunk-header stream)) + (stream-read-char stream)) + (end-of-file () :eof))) + ((> remaining-input 0) (decf remaining-input) + (call-next-method)) + ((zerop remaining-input) (handler-case + (progn + (gobble-crlf stream) + (setf remaining-input (read-chunk-header stream)) + (cond ((zerop remaining-input) + (setf input-chunking nil + output-chunking nil) + (signal 'excl::socket-chunking-end-of-file :format-arguments stream) + :eof) + (t (stream-read-char stream)))) + (end-of-file () :eof)))))) + +(defmethod stream-unread-char ((stream chunked-mixin) character) + (with-slots (input-chunking remaining-input) stream + (cond (*recursive* (call-next-method)) + (input-chunking (incf remaining-input) + (call-next-method)) + (t (call-next-method))))) + +(defmethod stream-read-line ((stream chunked-mixin)) + (loop + with chars = nil + for char = (stream-read-char stream) + until (eq char #\Linefeed) + do + (if (eq char :eof) + (if (null chars) + (error 'end-of-file :stream stream) + (return (coerce chars 'string))) + (push char chars)) + finally (return (coerce (nreverse chars) 'string)))) + +(defmethod stream-read-sequence ((stream chunked-mixin) sequence start end) + (loop + for i from start below end + do + (let ((char (stream-read-char stream))) + (case char + (:eof (return i)) + (t (setf (elt sequence i) char)))) + finally (return i))) + +(defmethod stream-clear-input ((stream chunked-mixin)) + (with-slots (input-chunking) stream + (cond (*recursive* (call-next-method)) + (input-chunking nil) + (t (call-next-method))))) + +(defmethod stream-write-byte ((stream chunked-mixin) byte) + (check-type byte unsigned-byte) + (if *recursive* + (call-next-method) + (with-slots (output-buffer) stream + (or (vector-push byte output-buffer) + (progn + (stream-force-output stream) + (stream-write-byte stream byte)))))) + +(defmethod stream-write-char ((stream chunked-mixin) character) + (if *recursive* + (call-next-method) + (stream-write-byte stream (char-code character)))) + +(defmethod stream-write-sequence ((stream chunked-mixin) sequence start end) + (loop + for i from start below end + do + (let ((e (elt sequence i))) + (etypecase e + (integer (stream-write-byte stream e)) + (character (stream-write-char stream e)))))) + +(defmethod stream-write-string ((stream chunked-mixin) string &optional + (start 0) (end (length string))) + (stream-write-sequence stream string start end)) + +(defmethod write-crlf ((stream stream)) + (let ((*recursive* t)) + (write-char #\Return stream) + (write-char #\Linefeed stream))) + +(defmethod stream-force-output ((stream chunked-mixin)) + (with-slots (output-chunking output-buffer) stream + (when (> (fill-pointer output-buffer) 0) + (let ((*recursive* t)) + (when output-chunking + (let ((*print-base* 16)) + (princ (fill-pointer output-buffer) stream)) + (write-crlf stream)) + (write-sequence output-buffer stream) + (setf (fill-pointer output-buffer) 0) + (when output-chunking + (write-crlf stream))))) + (call-next-method)) + +(defmethod stream-finish-output ((stream chunked-mixin)) + (unless *recursive* + (force-output stream)) + (call-next-method)) + +(defmethod stream-clear-output ((stream chunked-mixin)) + (with-slots (output-chunking output-buffer) stream + (if (and output-chunking (not *recursive*)) + (setf (fill-pointer output-buffer) 0) + (call-next-method)))) + +(defmethod close ((stream chunked-mixin) &key abort) + (unless abort + (finish-output stream)) + (with-slots (output-chunking output-buffer) stream + (when (and output-chunking + (> (fill-pointer output-buffer) 0)) + (close-chunk stream))) + (call-next-method)) + +(defmethod close-chunk ((stream chunked-mixin)) + (finish-output stream) + (with-slots (output-chunking input-chunking) stream + (if output-chunking + (let ((*recursive* t)) + (princ 0 stream) + (write-crlf stream) + (write-crlf stream) + (finish-output stream) + (setf output-chunking nil + input-chunking nil)) + (error "Chunking is not enabled for output on this stream: ~S." + stream)))) + +(provide :com.ljosa.chunked) + Added: branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-excl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-excl.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,70 @@ +;;;; +;;;; ACL-COMPAT - EXCL +;;;; + +;;;; Implementation-specific parts of acl-compat.excl (see +;;;; acl-excl-common.lisp) + +(in-package :acl-compat.excl) + +(defun fixnump (x) + (sys::fixnump x)) + +(defun stream-input-fn (stream) + stream) + +(defun filesys-type (file-or-directory-name) + ;; Taken from clocc's port library, with thanks to Sam Steingold + (if (values + (ignore-errors + (#+lisp=cl ext:probe-directory #-lisp=cl lisp:probe-directory + file-or-directory-name))) + :directory + (if (probe-file file-or-directory-name) + :file + nil))) + +(defmacro atomically (&body forms) + ;; No multiprocessing here, move along... + `(progn ,@forms)) + +(defun unix-signal (signal pid) + (declare (ignore signal pid)) + (error "clisp unix-signal not implemented yet.")) + +(defmacro without-package-locks (&body forms) + `(ext:without-package-lock ,(list-all-packages) ,@forms)) + +(defun fixnump (x) + (sys::fixnump x)) + +(defun string-to-octets (string &key (null-terminate t) (start 0) + end mb-vector make-mb-vector? + (external-format :default)) + "This function returns a lisp-usb8-vector and the number of bytes copied." + (declare (ignore external-format)) + ;; The end parameter is different in ACL's lambda list, but this + ;; variant lets us give an argument :end nil explicitly, and the + ;; right thing will happen + (unless end (setf end (length string))) + (let* ((number-of-octets (if null-terminate (1+ (- end start)) + (- end start))) + (mb-vector (cond + ((and mb-vector (>= (length mb-vector) number-of-octets)) + mb-vector) + ((or (not mb-vector) make-mb-vector?) + (make-array (list number-of-octets) + :element-type '(unsigned-byte 8) + :initial-element 0)) + (t (error "Was given a vector of length ~A, ~ + but needed at least length ~A." + (length mb-vector) number-of-octets))))) + (declare (type (simple-array (unsigned-byte 8) (*)) mb-vector)) + (loop for from-index from start below end + for to-index upfrom 0 + do (progn + (setf (aref mb-vector to-index) + (char-code (aref string from-index))))) + (when null-terminate + (setf (aref mb-vector (1- number-of-octets)) 0)) + (values mb-vector number-of-octets))) Added: branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-mp.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-mp.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,74 @@ +;; Stubs for multiprocessing functions under clisp. Clisp does not +;; provide threads at the time of writing, so these functions are here +;; only to compile aserve with a minimum of changes in the main code. +;; +;; Written by Rudi Schlatte + + +(in-package :acl-compat-mp) + +(defvar *current-process*) + +(defun process-allow-schedule () + (values)) + +(defun process-allow-scheduling () + (values)) + +(defun process-plist (process) + (declare (ignore process)) + (error "Attempting to use multithreading with clisp.")) + +(defun (setf process-plist) (new-value process) + (declare (ignore new-value process)) + (error "Attempting to use multithreading with clisp.")) + +(defun process-run-reasons (process) + (declare (ignore process)) + (error "Attempting to use multithreading with clisp.")) + +(defun (setf process-run-reasons) (new-value process) + (declare (ignore new-value process)) + (error "Attempting to use multithreading with clisp.")) + +(defun process-revoke-run-reason (process object) + (declare (ignore process object)) + (error "Attempting to use multithreading with clisp.")) + +(defun process-add-run-reason (process object) + (declare (ignore process object)) + (error "Attempting to use multithreading with clisp.")) + +(defun process-run-function (name function &rest arguments) + (declare (ignore name function arguments)) + (error "Attempting to use multithreading with clisp.")) + +(defun process-kill (process) + (declare (ignore process)) + (error "Attempting to use multithreading with clisp.")) + +(defmacro with-gensyms (syms &body body) + "Bind symbols to gensyms. First sym is a string - `gensym' prefix. +Inspired by Paul Graham, <On Lisp>, p. 145." + `(let (,@(mapcar (lambda (sy) `(,sy (gensym ,(car syms)))) (cdr syms))) + ,@body)) + +(defun interrupt-process (process function &rest args) + (declare (ignore process function args)) + (error "Attempting to use multithreading with clisp.")) + +(defun make-process-lock (&key name) + (declare (ignore name)) + (error "Attempting to use multithreading with clisp.")) + +(defmacro with-process-lock ((lock &key norecursive whostate timeout) + &body forms) + (declare (ignore lock norecursive whostate timeout)) + `(progn ,@forms)) + +(defmacro with-timeout ((seconds &body timeout-forms) &body body) + (declare (ignore seconds timeout-forms)) + `(progn ,@body)) + +(defmacro without-scheduling (&body body) + `(progn ,@body)) Added: branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-socket.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-socket.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,174 @@ +;; This package is designed for clisp. It implements the +;; ACL-style socket interface on top of clisp. +;; +;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt +;; for Lispworks and net.lisp in the port library of CLOCC. + +(in-package :acl-socket) + +(defclass server-socket () + ((port :type fixnum + :initarg :port + :reader port) + (stream-type :type (member :text :binary :bivalent) + :initarg :stream-type + :reader stream-type + :initform (error "No value supplied for stream-type")) + (clisp-socket-server :initarg :clisp-socket-server + :reader clisp-socket-server))) + +(defmethod print-object ((server-socket server-socket) stream) + (print-unreadable-object (server-socket stream :type t :identity nil) + (format stream "@port ~d" (port server-socket)))) + +(defun %get-element-type (format) + (ecase format + (:text 'character) + (:binary '(unsigned-byte 8)) + (:bivalent '(unsigned-byte 8))) ) + +(defgeneric accept-connection (server-socket &key wait)) +(defmethod accept-connection ((server-socket server-socket) + &key (wait t)) + "Return a bidirectional stream connected to socket, or nil if no +client wanted to initiate a connection and wait is nil." + (when (cond ((numberp wait) + (socket-wait (clisp-socket-server server-socket) wait)) + (wait (socket-wait (clisp-socket-server server-socket))) + (t (socket-wait (clisp-socket-server server-socket) 0))) + (let ((stream (socket-accept (clisp-socket-server server-socket) + :element-type (%get-element-type + (stream-type server-socket)) + ))) + (if (eq (stream-type server-socket) :bivalent) + (make-bivalent-stream stream) + stream)))) + + +(defun make-socket (&key (remote-host "localhost") + local-port + remote-port + (connect :active) + (format :text) + &allow-other-keys) + "Return a stream connected to remote-host if connect is :active, or +something listening on local-port that can be fed to accept-connection +if connect is :passive." + (check-type remote-host string) + (ecase connect + (:passive + (make-instance 'server-socket + :port local-port + :clisp-socket-server (socket-server local-port) + :stream-type format)) + (:active + (let ((stream (socket-connect + remote-port remote-host + :element-type (%get-element-type format) + ))) + (if (eq format :bivalent) + (make-bivalent-stream stream) + stream))))) + +(defmethod close ((server-socket server-socket) &key abort) + "Kill a passive (listening) socket. (Active sockets are actually +streams and handled by their close methods." + (declare (ignore abort)) + (socket-server-close (clisp-socket-server server-socket))) + +(declaim (ftype (function ((unsigned-byte 32)) (values simple-string)) + ipaddr-to-dotted)) +(defun ipaddr-to-dotted (ipaddr &key values) + (declare (type (unsigned-byte 32) ipaddr)) + (let ((a (logand #xff (ash ipaddr -24))) + (b (logand #xff (ash ipaddr -16))) + (c (logand #xff (ash ipaddr -8))) + (d (logand #xff ipaddr))) + (if values + (values a b c d) + (format nil "~d.~d.~d.~d" a b c d)))) + +(defun string-tokens (string) + (labels ((get-token (str pos1 acc) + (let ((pos2 (position #\Space str :start pos1))) + (if (not pos2) + (nreverse acc) + (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2)) + acc)))))) + (get-token (concatenate 'string string " ") 0 nil))) + +(declaim (ftype (function (string &key (:errorp t)) + (values (unsigned-byte 32))) + dotted-to-ipaddr)) +(defun dotted-to-ipaddr (dotted &key (errorp t)) + (declare (string dotted)) + (if errorp + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll))) + (ignore-errors + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll)))))) + + +(defun ipaddr-to-hostname (ipaddr &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported.")) + (posix::hostent-name (posix:resolve-host-ipaddr ipaddr))) + +(defun lookup-hostname (host &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported.")) + (if (stringp host) + (car (posix::hostent-addr-list (posix:resolve-host-ipaddr host))) + (dotted-to-ipaddr (ipaddr-to-dotted host)))) + +(defgeneric get-clisp-stream (stream)) + +(defmethod get-clisp-stream ((stream gray-stream::native-lisp-stream-mixin)) + (gray-stream::native-lisp-stream stream)) + +(defmethod get-clisp-stream ((stream t)) + (the stream stream)) + +(defun remote-host (socket-stream) + (dotted-to-ipaddr + (nth-value 0 (socket-stream-peer (get-clisp-stream socket-stream) t)))) + +(defun remote-port (socket-stream) + (nth-value 1 (socket-stream-peer (get-clisp-stream socket-stream) t))) + +(defun local-host (socket-stream) + (dotted-to-ipaddr + (nth-value 0 (socket-stream-local (get-clisp-stream socket-stream) t)))) + +(defun local-port (socket-stream) + (nth-value 1 (socket-stream-local (get-clisp-stream socket-stream) t))) + +;; Now, throw chunking in the mix + +(defclass chunked-stream (de.dataheaven.chunked-stream-mixin::chunked-stream-mixin + gray-stream::buffered-bivalent-stream) + ((plist :initarg :plist :accessor stream-plist))) + + +(defun make-bivalent-stream (lisp-stream &key plist) + (make-instance 'chunked-stream :lisp-stream lisp-stream :plist plist)) + + +(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p)) + (when oc-p + (when output-chunking + (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin::output-chunking-p stream) + output-chunking)) + (when output-chunking-eof + (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream)) + (when ic-p + (when input-chunking + (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin::input-chunking-p stream) + input-chunking))) + +(provide 'acl-socket) Added: branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-sys.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-sys.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,22 @@ + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ext:without-package-lock () + (let ((sys-package (find-package "SYSTEM"))) + (export (list (intern "COMMAND-LINE-ARGUMENTS" sys-package) + (intern "COMMAND-LINE-ARGUMENT" sys-package) + (intern "REAP-OS-SUBPROCESS" sys-package)) + sys-package)))) + +(ext:without-package-lock () + (defun sys:command-line-arguments () + ext:*args*)) + +(ext:without-package-lock () + (defun sys:command-line-argument (n) + (nth n ext:*args*))) + +(ext:without-package-lock () + (defun sys:reap-os-subprocess (&key (wait nil)) + (declare (ignore wait)) + nil)) + Added: branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-excl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-excl.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,71 @@ +;;;; +;;;; ACL-COMPAT - EXCL +;;;; + +;;;; Implementation-specific parts of acl-compat.excl (see +;;;; acl-excl-common.lisp) + +(in-package :acl-compat.excl) + +(defun stream-input-fn (stream) + stream) + +(defun filesys-type (file-or-directory-name) + (if (eq :directory (unix:unix-file-kind + (namestring file-or-directory-name))) + :directory + (if (probe-file file-or-directory-name) + :file + nil))) + +(defmacro atomically (&body forms) + `(mp:without-scheduling ,@forms)) + +(defun unix-signal (signal pid) + ;; fixxme: did I get the arglist right? only invocation I have seen + ;; is (excl::unix-signal 15 0) in net.aserve:start + (unix:unix-kill pid signal)) + +(defmacro without-package-locks (&body forms) + `(progn ,@forms)) + +(defun filesys-inode (path) + (multiple-value-bind (found ign inode) + (unix:unix-lstat path) + (if found + inode + (error "path ~s does not exist" path)))) + +(defun cl-internal-real-time () + (round (/ (get-internal-real-time) internal-time-units-per-second))) + +(defun string-to-octets (string &key (null-terminate t) (start 0) + end mb-vector make-mb-vector? + (external-format :default)) + "This function returns a lisp-usb8-vector and the number of bytes copied." + (declare (ignore external-format)) + ;; The end parameter is different in ACL's lambda list, but this + ;; variant lets us give an argument :end nil explicitly, and the + ;; right thing will happen + (unless end (setf end (length string))) + (let* ((number-of-octets (if null-terminate (1+ (- end start)) + (- end start))) + (mb-vector (cond + ((and mb-vector (>= (length mb-vector) number-of-octets)) + mb-vector) + ((or (not mb-vector) make-mb-vector?) + (make-array (list number-of-octets) + :element-type '(unsigned-byte 8) + :initial-element 0)) + (t (error "Was given a vector of length ~A, ~ + but needed at least length ~A." + (length mb-vector) number-of-octets))))) + (declare (type (simple-array (unsigned-byte 8) (*)) mb-vector)) + (loop for from-index from start below end + for to-index upfrom 0 + do (progn + (setf (aref mb-vector to-index) + (char-code (aref string from-index))))) + (when null-terminate + (setf (aref mb-vector (1- number-of-octets)) 0)) + (values mb-vector number-of-octets))) Added: branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-mp.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-mp.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,170 @@ +;; This package is designed for cmucl. It implements ACL-style +;; multiprocessing on top of cmucl (basically, process run reasons and +;; some function renames). +;; +;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt +;; for Lispworks. + +(in-package :acl-compat.mp) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Import equivalent parts from the CMU MP package ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(shadowing-import '(mp:*current-process* + ;; mp::process-preset + mp::process-reset + mp:process-interrupt + mp::process-name + mp::process-wait-function + mp:process-run-reasons + mp:process-add-run-reason + mp:process-revoke-run-reason + mp:process-arrest-reasons + mp:process-add-arrest-reason + mp:process-revoke-arrest-reason + mp:process-whostate + ; mp:without-interrupts + mp:process-wait + mp:with-timeout + mp:without-scheduling + mp:process-active-p + )) + +(export '(*current-process* + ;; process-preset + process-reset + process-interrupt + process-name + process-wait-function + process-whostate + process-wait + with-timeout + without-scheduling + process-run-reasons + process-add-run-reason + process-revoke-run-reason + process-arrest-reasons + process-add-arrest-reason + process-revoke-arrest-reason + process-active-p + )) + + +(defun process-allow-schedule () + (mp:process-yield)) + +(defvar *process-plists* (make-hash-table :test #'eq) + "maps processes to their plists. +See the functions process-plist, (setf process-plist).") + +(defun process-property-list (process) + (gethash process *process-plists*)) + +(defun (setf process-property-list) (new-value process) + (setf (gethash process *process-plists*) new-value)) + +#|| + +;;; rudi 2002-06-09: This is not needed as of cmucl 18d, thanks to Tim +;;; Moore who added run reasons to cmucl's multithreading. Left in +;;; for the time being just in case someone wants to get acl-compat +;;; running on older cmucl's. Can be deleted safely. + +(defvar *process-run-reasons* (make-hash-table :test #'eq) + "maps processes to their run-reasons. +See the functions process-run-reasons, (setf process-run-reasons), +process-add-run-reason, process-revoke-run-reason.") + +(defun process-run-reasons (process) + (gethash process *process-run-reasons*)) + +(defun (setf process-run-reasons) (new-value process) + (mp:without-scheduling + (prog1 + (setf (gethash process *process-run-reasons*) new-value) + (if new-value + (mp:enable-process process) + (mp:disable-process process))))) + +(defun process-revoke-run-reason (process object) + (without-scheduling + (setf (process-run-reasons process) + (remove object (process-run-reasons process)))) + (when (and (eq process mp:*current-process*)) + (mp:process-yield))) + +(defun process-add-run-reason (process object) + (setf (process-run-reasons process) + (pushnew object (process-run-reasons process)))) +||# + +(defun process-run-function (name-or-options preset-function + &rest preset-arguments) + (let ((process (etypecase name-or-options + (string (make-process :name name-or-options + :run-reasons '(t))) + (list (apply #'make-process :run-reasons '(t) + name-or-options))))) + (apply #'acl-mp::process-preset process preset-function preset-arguments) + process)) + +(defun process-preset (process preset-function &rest arguments) + (mp:process-preset process + #'(lambda () + (apply-with-bindings preset-function + arguments + (process-initial-bindings process))))) + +(defvar *process-initial-bindings* (make-hash-table :test #'eq)) + +(defun process-initial-bindings (process) + (gethash process *process-initial-bindings*)) + +(defun (setf process-initial-bindings) (bindings process) + (setf (gethash process *process-initial-bindings*) bindings)) + + +;;; ;;; +;;; Contributed by Tim Moore ;;; +;;; ;;; +(defun apply-with-bindings (function args bindings) + (if bindings + (progv + (mapcar #'car bindings) + (mapcar #'(lambda (binding) + (eval (cdr binding))) + bindings) + (apply function args)) + (apply function args))) + +(defun make-process (&key (name "Anonymous") reset-action run-reasons + arrest-reasons (priority 0) quantum resume-hook + suspend-hook initial-bindings run-immediately) + (declare (ignore priority quantum reset-action resume-hook suspend-hook + run-immediately)) + (mp:make-process nil :name name + :run-reasons run-reasons + :arrest-reasons arrest-reasons + :initial-bindings initial-bindings)) + +(defun process-kill (process) + (mp:destroy-process process)) + + +(defun make-process-lock (&key name) + (mp:make-lock name)) + +(defun process-lock (lock) + (mp::lock-wait lock (mp:process-whostate mp:*current-process*))) + +(defun process-unlock (lock) + (setf (mp::lock-process lock) nil)) + + +(defmacro with-process-lock ((lock &key norecursive whostate timeout) &body forms) + (declare (ignore norecursive)) + `(mp:with-lock-held (,lock + ,@(when whostate (list :whostate whostate)) + ,@(when timeout (list :timeout timeout))) + ,@forms)) Added: branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-socket.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-socket.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,208 @@ +;; This package is designed for cmucl. It implements the +;; ACL-style socket interface on top of cmucl. +;; +;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt +;; for Lispworks and net.lisp in the port library of CLOCC. + +(in-package acl-compat.socket) + +(defclass socket () + ((fd :type fixnum + :initarg :fd + :reader fd))) + +(defmethod print-object ((socket socket) stream) + (print-unreadable-object (socket stream :type t :identity t) + (format stream "@~d" (fd socket)))) + +(defclass server-socket (socket) + ((element-type :type (member signed-byte unsigned-byte base-char) + :initarg :element-type + :reader element-type + :initform (error "No value supplied for element-type")) + (port :type fixnum + :initarg :port + :reader port + :initform (error "No value supplied for port")) + (stream-type :type (member :text :binary :bivalent) + :initarg :stream-type + :reader stream-type + :initform (error "No value supplied for stream-type")))) + +#+cl-ssl +(defmethod make-ssl-server-stream ((lisp-stream system:lisp-stream) + &rest options) + (apply #'make-ssl-server-stream (system:fd-stream-fd lisp-stream) options)) + +(defmethod print-object ((socket server-socket) stream) + (print-unreadable-object (socket stream :type t :identity nil) + (format stream "@~d on port ~d" (fd socket) (port socket)))) + +(defmethod accept-connection ((server-socket server-socket) + &key (wait t)) + "Return a bidirectional stream connected to socket, or nil if no +client wanted to initiate a connection and wait is nil." + ;; fixxme: perhaps check whether we run multiprocessing and use + ;; sys:wait-until-fd-usable instead of + ;; mp:process-wait-until-fd-usable here? + + ;; api pipe fitting: wait t ==> timeout nil + (when (mp:process-wait-until-fd-usable (fd server-socket) :input + (if wait nil 0)) + (let ((stream (sys:make-fd-stream + (ext:accept-tcp-connection (fd server-socket)) + :input t :output t + :element-type (element-type server-socket) + :auto-close t))) + (if (eq (stream-type server-socket) :bivalent) + (make-bivalent-stream stream) + stream)))) + +(defun make-socket (&key (remote-host "localhost") + local-port + remote-port + (connect :active) + (format :text) + (reuse-address t) + &allow-other-keys) + "Return a stream connected to remote-host if connect is :active, or +something listening on local-port that can be fed to accept-connection +if connect is :passive. + +This is an incomplete implementation of ACL's make-socket function! +It was written to provide the functionality necessary to port +AllegroServe. Refer to +http://franz.com/support/documentation/6.1/doc/pages/operators/socket/make-socket.htm +to read about the missing parts." + (check-type remote-host string) + (let ((element-type (ecase format + (:text 'base-char) + (:binary 'signed-byte) + (:bivalent 'unsigned-byte)))) + (ecase connect + (:passive + (make-instance 'server-socket + :port local-port + :fd (ext:create-inet-listener local-port :stream :reuse-address reuse-address) + :element-type element-type + :stream-type format)) + (:active + (let ((stream (sys:make-fd-stream + (ext:connect-to-inet-socket remote-host remote-port) + :input t :output t :element-type element-type))) + (if (eq :bivalent format) + (make-bivalent-stream stream) + stream)))))) + +(defmethod close ((server server-socket) &key abort) + "Kill a passive (listening) socket. (Active sockets are actually +streams and handled by their close methods." + (declare (ignore abort)) + (unix:unix-close (fd server))) + +(declaim (ftype (function ((unsigned-byte 32) &key (:values t)) + (values simple-string)) + ipaddr-to-dotted)) +(defun ipaddr-to-dotted (ipaddr &key values) + (declare (type (unsigned-byte 32) ipaddr)) + (let ((a (logand #xff (ash ipaddr -24))) + (b (logand #xff (ash ipaddr -16))) + (c (logand #xff (ash ipaddr -8))) + (d (logand #xff ipaddr))) + (if values + (values a b c d) + (format nil "~d.~d.~d.~d" a b c d)))) + +(defun string-tokens (string) + (labels ((get-token (str pos1 acc) + (let ((pos2 (position #\Space str :start pos1))) + (if (not pos2) + (nreverse acc) + (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2)) + acc)))))) + (get-token (concatenate 'string string " ") 0 nil))) + +(declaim (ftype (function (string &key (:errorp t)) + (values (unsigned-byte 32))) + dotted-to-ipaddr)) +(defun dotted-to-ipaddr (dotted &key (errorp t)) + (declare (string dotted)) + (if errorp + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll))) + (ignore-errors + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll)))))) + +(defun ipaddr-to-hostname (ipaddr &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported.")) + (ext:host-entry-name (ext:lookup-host-entry ipaddr))) + +(defun lookup-hostname (host &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported.")) + (if (stringp host) + (car (ext:host-entry-addr-list (ext:lookup-host-entry host))) + (dotted-to-ipaddr (ipaddr-to-dotted host)))) + +(defgeneric get-fd (stream)) + +(defmethod get-fd ((stream gray-stream::native-lisp-stream-mixin)) + (system:fd-stream-fd (gray-stream::native-lisp-stream stream))) + +(defmethod get-fd ((stream system:lisp-stream)) + (system:fd-stream-fd stream)) + +(defmethod get-fd ((stream server-socket)) + (fd stream)) + +(defun remote-host (socket-stream) + (ext:get-peer-host-and-port (get-fd socket-stream))) + +(defun remote-port (socket-stream) + (multiple-value-bind (host port) + (ext:get-peer-host-and-port (get-fd socket-stream)) + (declare (ignore host)) + port)) + +(defun local-host (socket-stream) + (ext:get-socket-host-and-port (get-fd socket-stream))) + +(defun local-port (socket-stream) + (if (typep socket-stream 'socket::server-socket) + (port socket-stream) + (multiple-value-bind (host port) + (ext:get-socket-host-and-port (get-fd socket-stream)) + (declare (ignore host)) + port))) + +;; Now, throw chunking in the mix + +(defclass chunked-stream (de.dataheaven.chunked-stream-mixin::chunked-stream-mixin + gray-stream::buffered-bivalent-stream) + ()) + + +(defun make-bivalent-stream (lisp-stream) + (make-instance 'chunked-stream :lisp-stream lisp-stream)) + + +(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p)) + (when oc-p + (when output-chunking + (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin::output-chunking-p stream) + output-chunking)) + (when output-chunking-eof + (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream)) + (when ic-p + (when input-chunking + (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin::input-chunking-p stream) + input-chunking))) + + +(provide 'acl-socket) Added: branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-sys.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-sys.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,18 @@ +(in-package :acl-compat.system) + +(ignore-errors +(export 'command-line-arguments) +(export 'command-line-argument) +(export 'reap-os-subprocess) + +(defun command-line-arguments () + ext:*command-line-strings*) + +(defun command-line-argument (n) + (nth n ext:*command-line-strings*)) + +(defun reap-os-subprocess (&key (wait nil)) + (declare (ignore wait)) + nil) + +) Added: branches/trunk-reorg/thirdparty/acl-compat/defsys.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/defsys.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,50 @@ +(in-package "CL-USER") + +(defsystem "ACL-COMPAT" + (:default-pathname "ACL-COMPAT:") + :members + ("acl-compat-common-lisp-lw" + "nregex" + "acl-excl-lw" + "acl-mp-package" + "acl-mp-lw" + "gray-stream-package" + "acl-socket-lw" + "acl-sys-lw" + "meta" + "uri" + "chunked-stream-mixin") + + :rules + ((:in-order-to :compile "acl-excl-lw" + (:caused-by (:compile "nregex")) + (:requires (:load "nregex"))) + (:in-order-to :load "acl-excl-lw" + (:requires (:load "nregex"))) + + (:in-order-to :compile "acl-mp-lw" + (:caused-by (:compile "acl-mp-package" "acl-socket-lw")) + (:requires (:load "acl-mp-package" "acl-socket-lw"))) + (:in-order-to :load "acl-mp-lw" + (:requires (:load "acl-mp-package" "acl-socket-lw"))) + + (:in-order-to :compile "acl-socket-lw" + (:caused-by (:compile "chunked-stream-mixin")) + (:requires (:load "chunked-stream-mixin"))) + (:in-order-to :load "acl-socket-lw" + (:requires (:load "chunked-stream-mixin"))) + + (:in-order-to :compile "chunked-stream-mixin" + (:caused-by (:compile "acl-excl-lw" "gray-stream-package")) + (:requires (:load "acl-excl-lw" "gray-stream-package"))) + (:in-order-to :load "chunked-stream-mixin" + (:requires (:load "acl-excl-lw" "gray-stream-package"))) + + (:in-order-to :compile "uri" + (:caused-by (:compile "meta")) + (:requires (:load "meta"))) + (:in-order-to :load "uri" + (:requires (:load "meta"))))) + +(eval-when (:load-toplevel :execute) + (pushnew :acl-compat *features*)) Added: branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-excl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-excl.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,85 @@ +;;;; +;;;; ACL-COMPAT - EXCL +;;;; + +;;;; Implementation-specific parts of acl-compat.excl (see +;;;; acl-excl-common.lisp) + +(in-package :acl-compat.excl) + +#+obsolete +(defun stream-input-fn (stream) + stream) + +(defmethod stream-input-fn ((stream stream)) + stream) + +(defun filesys-type (file-or-directory-name) + (if (lw::file-directory-p file-or-directory-name) + :directory + (if (probe-file file-or-directory-name) + :file + nil))) + +#-:win32 +(defun filesys-inode (path) + (let ((checked-path (probe-file path))) + (cond + (checked-path (let ((stat (system:get-file-stat checked-path))) + (system:file-stat-inode stat))) + (t (error "path ~a does not exist." path))))) + +(defmacro atomically (&body forms) + `(mp:without-preemption ,@forms)) + +(defmacro without-package-locks (&body forms) + `(progn ,@forms)) + + +#| +(defun run-shell-command () + (with-open-stream (s (open-pipe "/bin/sh" + :direction :io + :buffered nil)) + (loop for var in environment + do (format stream "~A=~A~%" (car var) (cdr var))) +|# + +;; NDL 2004-06-04 -- Missing definition & a package, to allow LispWorks to load webactions + +(defun cl-internal-real-time () + (round (/ (get-internal-real-time) 1000))) + +(defun string-to-octets (string &key (null-terminate t) (start 0) + end mb-vector make-mb-vector? + (external-format :default)) + "This function returns a lisp-usb8-vector and the number of bytes copied." + (declare (ignore external-format)) + ;; The end parameter is different in ACL's lambda list, but this + ;; variant lets us give an argument :end nil explicitly, and the + ;; right thing will happen + (unless end (setf end (length string))) + (let* ((number-of-octets (if null-terminate (1+ (- end start)) + (- end start))) + (mb-vector (cond + ((and mb-vector (>= (length mb-vector) number-of-octets)) + mb-vector) + ((or (not mb-vector) make-mb-vector?) + (make-array (list number-of-octets) + :element-type '(unsigned-byte 8) + :initial-element 0)) + (t (error "Was given a vector of length ~A, ~ + but needed at least length ~A." + (length mb-vector) number-of-octets))))) + (declare (type (simple-array (unsigned-byte 8) (*)) mb-vector)) + (loop for from-index from start below end + for to-index upfrom 0 + do (progn + (setf (aref mb-vector to-index) + (char-code (aref string from-index))))) + (when null-terminate + (setf (aref mb-vector (1- number-of-octets)) 0)) + (values mb-vector number-of-octets))) + + +(provide 'acl-excl) Added: branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-mp.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-mp.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,209 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: CL-USER; -*- +;;;; ; +;;;; (c) 2001 by Jochen Schmidt. +;;;; +;;;; File: acl-mp-lw.lisp +;;;; Revision: 1.0.0 +;;;; Description: LispWorks implementation for ACL-COMPAT-MP +;;;; Date: 02.02.2002 +;;;; Authors: Jochen Schmidt +;;;; Tel: (+49 9 11) 47 20 603 +;;;; Email: jsc(a)dataheaven.de +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; 2. 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 "AS IS" AND THERE ARE NEITHER +;;;; EXPRESSED NOR IMPLIED WARRANTIES - THIS INCLUDES, BUT +;;;; IS NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY +;;;; AND FITNESS FOR A PARTICULAR PURPOSE.IN NO WAY ARE THE +;;;; AUTHORS 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) +;;;; +;;;; For further details contact the authors of this software. +;;;; +;;;; Jochen Schmidt +;;;; Zuckmantelstr. 11 +;;;; 91616 Neusitz +;;;; GERMANY +;;;; +;;;; + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "comm")) + +(in-package :acl-compat-mp) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Import equivalent parts from the LispWorks MP package ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(shadowing-import '( + mp:*current-process* + mp:process-kill + mp:process-enable + mp:process-disable + mp::process-preset + mp:process-reset + mp:process-interrupt + mp::process-name + mp:process-wait-function + mp:process-run-reasons + mp:process-arrest-reasons + mp:process-whostate + mp:without-interrupts + mp:process-wait + mp::process-active-p + )) + +(export '( *current-process* + process-kill + process-enable + process-disable + process-preset + process-reset + process-interrupt + process-name + process-wait-function + process-run-reasons + process-arrest-reasons + process-whostate + without-interrupts + process-wait + process-active-p + )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Implement missing (and differing) functions ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun make-process (&key (name "Anonymous") reset-action run-reasons arrest-reasons (priority 0) quantum + resume-hook suspend-hook initial-bindings run-immediately) + (declare (ignore priority quantum reset-action resume-hook suspend-hook run-immediately)) + (let ((mp:*process-initial-bindings* initial-bindings)) + (mp:create-process name :run-reasons run-reasons :arrest-reasons arrest-reasons))) + +(defun process-run-function (name-or-options preset-function &rest preset-arguments) + (let ((process (ctypecase name-or-options + (string (make-process :name name-or-options)) + (list (apply #'make-process name-or-options))))) + (apply #'mp::process-preset process preset-function preset-arguments) + (push :enable (mp:process-run-reasons process)) + process)) + +(defun process-property-list (process) + (mp:process-plist process)) + +(defun (setf process-property-list) (new-value process) + (setf (mp:process-plist process) new-value)) + +(defun process-name-to-process (name &optional abbrev) + (if abbrev + (let ((length (length name))) + (dolist (process (mp:list-all-processes)) + (when (and (>= (length (process-name process)) length) + (string= name (process-name process) :end2 length)) + (return process)))) + (mp:find-process-from-name (ctypecase name + (symbol (symbol-name name)) + (string name))))) + +(defun process-wait-with-timeout (whostate seconds function &rest args) + (apply #'mp:process-wait-with-timeout whostate seconds function args)) + +(defun wait-for-input-available (streams &key (wait-function #'socket::stream-input-available) whostate timeout) + (let ((collected-fds nil)) + (flet ((fd (stream-or-fd) + (typecase stream-or-fd + (comm:socket-stream (comm:socket-stream-socket stream-or-fd)) + (socket::passive-socket (socket::socket-os-fd stream-or-fd)) + (fixnum stream-or-fd))) + (collect-fds () + (setf collected-fds + (remove-if-not wait-function streams)))) + + #+unix + (unwind-protect + (progn + (dolist (stream-or-fd streams) + (mp:notice-fd (fd stream-or-fd))) + (if timeout + (mp:process-wait-with-timeout (or whostate "Waiting for input") timeout #'collect-fds) + (mp:process-wait (or whostate "Waiting for input") #'collect-fds))) + (dolist (stream-or-fd streams) + (mp:unnotice-fd (fd stream-or-fd)))) + #-unix + (if timeout + (mp:process-wait-with-timeout (or whostate "Waiting for input") timeout #'collect-fds) + (mp:process-wait (or whostate "Waiting for input") #'collect-fds))) + collected-fds)) + +(defmacro without-scheduling (&body forms) + `(mp:without-preemption ,@forms)) + +(defun process-allow-schedule (&optional process) + (declare (ignore process)) + (mp:process-allow-scheduling)) + +(defun process-revoke-run-reason (process object) + (mp:without-preemption + (setf (mp:process-run-reasons process) + (remove object (mp:process-run-reasons process)))) + (when (and (eq process mp:*current-process*) + (not mp:*inhibit-scheduling-flag*)) + (mp:process-allow-scheduling))) + +(defun process-add-run-reason (process object) + (setf (mp:process-run-reasons process) (pushnew object (mp:process-run-reasons process)))) + +;revised version from alain picard +(defun invoke-with-timeout (timeout bodyfn timeoutfn) + (block timeout + (let* ((process mp:*current-process*) + (unsheduled? nil) + (timer (mp:make-timer + #'(lambda () + (mp:process-interrupt process + #'(lambda () + (unless unsheduled? + (return-from timeout + (funcall timeoutfn))))))))) + (mp:schedule-timer-relative timer timeout) + (unwind-protect (funcall bodyfn) + (without-interrupts + (mp:unschedule-timer timer) + (setf unsheduled? t)))))) + + +(defmacro with-timeout ((seconds &body timeout-forms) &body body) + "Execute BODY; if execution takes more than SECONDS seconds, terminate +and evaluate TIMEOUT-FORMS." + `(invoke-with-timeout ,seconds #'(lambda () ,@body) + #'(lambda () ,@timeout-forms))) + +(defun current-process () + "The current process." + mp:*current-process*) + +(defun interrupt-process (process function &rest args) + "Run FUNCTION in PROCESS." + (apply #'mp:process-interrupt process function args)) + +(defun make-process-lock (&key name) + (mp:make-lock :name name)) + +(defmacro with-process-lock ((lock &key norecursive timeout whostate) &body forms) + (declare (ignore norecursive)) + `(mp:with-lock (,lock + ,@(when whostate (list :whostate whostate)) + ,@(when timeout (list :timeout timeout))) + ,@forms)) + Added: branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-socket.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-socket.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,311 @@ +;; This package is designed for LispWorks. It implements the +;; ACL-style socket interface on top of LispWorks. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "comm")) + +#+cl-ssl +(eval-when (:compile-toplevel :load-toplevel :execute) +(ssl-internal::initialize-ssl-library) +) + +(in-package acl-compat.socket) + +(define-condition stream-error (error) + ((acl-compat.excl::stream :initarg :stream + :reader stream-error-stream) + (acl-compat.excl::action :initarg :action + :reader stream-error-action) + (acl-compat.excl::code :initarg :code + :reader stream-error-code) + (acl-compat.excl::identifier :initarg :identifier + :reader stream-error-identifier)) + (:report (lambda (condition stream) + (format stream "A stream error occured (action=~A identifier=~A code=~A stream=~S)." + (stream-error-action condition) + (stream-error-identifier condition) + (stream-error-code condition) + (stream-error-stream condition))))) + +(define-condition socket-error (stream-error) + () + (:report (lambda (condition stream) + (format stream "A socket error occured (action=~A identifier=~A code=~A stream=~S)." + (stream-error-action condition) + (stream-error-identifier condition) + (stream-error-code condition) + (stream-error-stream condition))))) + +#+unix +(defun %socket-error-identifier (code) + (case code + (32 :x-broken-pipe) + (98 :address-in-use) + (99 :address-not-available) + (100 :network-down) + (102 :network-reset) + (103 :connection-aborted) + (104 :connection-reset) + (105 :no-buffer-space) + (108 :shutdown) + (110 :connection-timed-out) + (111 :connection-refused) + (112 :host-down) + (113 :host-unreachable) + (otherwise :unknown))) + +#+win32 +(defun %socket-error-identifier (code) + (case code + (10048 :address-in-use) + (10049 :address-not-available) + (10050 :network-down) + (10052 :network-reset) + (10053 :connection-aborted) + (10054 :connection-reset) + (10055 :no-buffer-space) + (10058 :shutdown) + (10060 :connection-timed-out) + (10061 :connection-refused) + (10064 :host-down) + (10065 :host-unreachable) + (otherwise :unknown))) + +(defun socket-error (stream error-code action format-string &rest format-args) + (declare (ignore format-string format-args)) ;no valid initargs for this with socket-error + (let ((code (if (numberp error-code) error-code #+unix(lw:errno-value)))) + (error 'socket-error :stream stream :code code + :identifier (if (keywordp error-code) + error-code + (%socket-error-identifier error-code)) + :action action))) + + +(defclass socket () + ((passive-socket :type fixnum + :initarg :passive-socket + :reader socket-os-fd))) + +(defclass passive-socket (socket) + ((element-type :type (member signed-byte unsigned-byte base-char) + :initarg :element-type + :reader element-type) + (port :type fixnum + :initarg :port + :reader local-port))) + +(defclass binary-socket-stream (de.dataheaven.chunked-stream-mixin:chunked-stream-mixin comm:socket-stream) ()) +(defclass input-binary-socket-stream (binary-socket-stream)()) +(defclass output-binary-socket-stream (binary-socket-stream)()) +(defclass bidirectional-binary-socket-stream (input-binary-socket-stream output-binary-socket-stream)()) + + +(defmethod comm::socket-error ((stream binary-socket-stream) error-code format-string &rest format-args) + (apply #'socket-error stream error-code :IO format-string format-args)) + + +(declaim (inline %reader-function-for-sequence)) +(defun %reader-function-for-sequence (sequence) + (typecase sequence + (string #'read-char) + ((array unsigned-byte (*)) #'read-byte) + ((array signed-byte (*)) #'read-byte) + (otherwise #'read-byte))) + +;; Bivalent socket support for READ-SEQUENCE +(defmethod gray-stream:stream-read-sequence ((stream input-binary-socket-stream) sequence start end) + (stream::read-elements stream sequence start end (%reader-function-for-sequence sequence))) + +;; NDL 2004-06-06 -- without this, emit-clp-entity tries writing a string down a binary stream, and LW barfs +(defmethod gray-stream:stream-write-sequence ((stream output-binary-socket-stream) (sequence string) start end) + (write-string sequence stream :start start :end end)) + +;; ACL Gray-Streams Enhancment Generic Functions + +(defmethod stream-input-fn ((stream input-binary-socket-stream)) + (comm:socket-stream-socket stream)) + +(defmethod stream-output-fn ((stream output-binary-socket-stream)) + (comm:socket-stream-socket stream)) + +(defmethod socket-os-fd ((socket comm:socket-stream)) + (comm:socket-stream-socket socket)) + +(defmethod print-object ((passive-socket passive-socket) stream) + (print-unreadable-object (passive-socket stream :type t :identity nil) + (format stream "@~d on port ~d" (socket-os-fd passive-socket) (local-port passive-socket)))) + +(defmethod stream-input-available ((fd fixnum)) + (comm::socket-listen fd)) + +(defmethod stream-input-available ((stream stream::os-file-handle-stream)) + (stream-input-available (stream::os-file-handle-stream-file-handle stream))) + +(defmethod stream-input-available ((stream comm:socket-stream)) + (or (comm::socket-listen (comm:socket-stream-socket stream)) + (listen stream))) + +(defmethod stream-input-available ((stream socket::passive-socket)) + (comm::socket-listen (socket::socket-os-fd stream))) + + +(defmethod accept-connection ((passive-socket passive-socket) + &key (wait t)) + (if (or wait (stream-input-available passive-socket)) + (make-instance 'bidirectional-binary-socket-stream + :socket (comm::get-fd-from-socket (socket-os-fd passive-socket)) + :direction :io + :element-type (element-type passive-socket)))) + +(defun %new-passive-socket (local-port) + (multiple-value-bind (socket error-location error-code) + (comm::create-tcp-socket-for-service local-port) + (cond (socket socket) + (t (error 'socket-error :action error-location :code error-code :identifier :unknown))))) + +(defun make-socket (&key (remote-host "localhost") + local-port + remote-port + (connect :active) + (format :text) + (reuse-address t) + &allow-other-keys) + (declare (ignore format)) + (check-type remote-host string) + (ecase connect + (:passive + (let ((comm::*use_so_reuseaddr* reuse-address)) + (make-instance 'passive-socket + :port local-port + :passive-socket (%new-passive-socket local-port) + :element-type '(unsigned-byte 8)))) + (:active + (handler-case + (let ((stream (comm:open-tcp-stream remote-host remote-port + :direction :io + :element-type '(unsigned-byte 8) + :errorp t))) + (change-class stream 'bidirectional-binary-socket-stream)) + (simple-error (condition) + (let ((code (first (last (simple-condition-format-arguments condition))))) + (socket-error condition code + :connect "~A occured while connecting (~?)" (simple-condition-format-arguments condition)))))))) + + +(defmethod close ((passive-socket passive-socket) &key abort) + (declare (ignore abort)) + (comm::close-socket (socket-os-fd passive-socket))) + +;(declaim (ftype (function ((unsigned-byte 32)) (values simple-string)) +; ipaddr-to-dotted)) +(defun ipaddr-to-dotted (ipaddr &key values) + ;(declare (type (unsigned-byte 32) ipaddr)) + (if ipaddr ;sometimes ipaddr is nil in the log call if client has broken the connection + (let ((a (logand #xff (ash ipaddr -24))) + (b (logand #xff (ash ipaddr -16))) + (c (logand #xff (ash ipaddr -8))) + (d (logand #xff ipaddr))) + (if values + (values a b c d) + (format nil "~d.~d.~d.~d" a b c d))) + (if values (values 0 0 0 0) "0.0.0.0"))) + +(defun string-tokens (string) + (labels ((get-token (str pos1 acc) + (let ((pos2 (position #\Space str :start pos1))) + (if (not pos2) + (nreverse acc) + (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2)) + acc)))))) +(get-token (concatenate 'string string " ") 0 nil))) + +(declaim (ftype (function (string &key (:errorp t)) + (values (unsigned-byte 32))) + dotted-to-ipaddr)) +(defun dotted-to-ipaddr (dotted &key (errorp t)) + (declare (string dotted)) + (if errorp + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll))) + (ignore-errors + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll)))))) + +(defun ipaddr-to-hostname (ipaddr &key ignore-cache) + (declare (ignore ignore-cache)) + (multiple-value-bind (name) + (comm:get-host-entry (ipaddr-to-dotted ipaddr) :fields '(:name)) + name)) + +(defun lookup-hostname (host &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported.")) + (if (stringp host) + (multiple-value-bind (addr) + (comm:get-host-entry host :fields '(:address)) + addr) + (dotted-to-ipaddr (ipaddr-to-dotted host)))) + +(defmethod remote-host ((socket comm:socket-stream)) + (comm:socket-stream-peer-address socket)) + +(defmethod remote-port ((socket comm:socket-stream)) + (multiple-value-bind (host port) + (comm:socket-stream-peer-address socket) + (declare (ignore host)) + port)) + +(defmethod local-host ((socket comm:socket-stream)) + (multiple-value-bind (host port) + (comm:socket-stream-address socket) + (declare (ignore port)) + host)) + +(defmethod local-port ((socket comm:socket-stream)) + (multiple-value-bind (host port) + (comm:socket-stream-address socket) + (declare (ignore host)) + port)) + +(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p)) + (when oc-p + (when output-chunking + (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin:output-chunking-p stream) output-chunking)) + (when output-chunking-eof + (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream)) + (when ic-p + (when input-chunking + (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin:input-chunking-p stream) input-chunking))) + +#+(and :lispworks4.4 (not :cl-ssl)) +(defmethod make-ssl-client-stream ((socket-stream bidirectional-binary-socket-stream) &rest options) + (declare (ignore options)) + (comm:attach-ssl socket-stream :ssl-ctx t :ssl-side :client) + socket-stream) + +#+(and :lispworks4.4 (not :cl-ssl)) +(defun initialize-ssl-library () + ;; Dunno how to force load yet + (comm:ensure-ssl)) + +#+(and :lispworks4.4 (not :cl-ssl)) +(defmethod make-ssl-server-stream ((socket-stream bidirectional-binary-socket-stream) &key certificate certificate-password) + (flet ((ctx-configure-callback (ctx) + (comm:ssl-ctx-use-privatekey-file ctx + certificate-password + comm:SSL_FILETYPE_PEM)) + (ssl-configure-callback (ssl) + (comm:ssl-use-certificate-file ssl + certificate + comm:SSL_FILETYPE_PEM))) + (comm:attach-ssl socket-stream + :ssl-side :server + :ctx-configure-callback #'ctx-configure-callback + :ssl-configure-callback #'ssl-configure-callback)) + socket-stream) + +(provide 'acl-socket) Added: branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-sys.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-sys.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,24 @@ +(in-package :sys) +(let ((*handle-warn-on-redefinition* :warn)) +; (*packages-for-warn-on-redefinition* nil)) + + (defun command-line-arguments () + system:*line-arguments-list*) + + (defun command-line-argument (n) + (nth n system:*line-arguments-list*)) + + (defun reap-os-subprocess (&key (wait nil)) + (declare (ignore wait)) + nil) + + (export 'command-line-arguments) + (export 'command-line-argument) + (export 'reap-os-subprocess)) + +;; Franz uses the MSWINDOWS feature conditional in some of their code; +;; thus, under Windows, ACL-COMPAT should probably push MSWINDOWS +;; onto the *features* list when it detects the presence of WIN32 +;; under Lispworks. +#+WIN32 (eval-when (:compile-toplevel :load-toplevel :execute) + (pushnew :mswindows *features*)) Added: branches/trunk-reorg/thirdparty/acl-compat/lw-buffering.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/lw-buffering.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,261 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; LW Style Buffer Protocol for other Lisps ;;; +;;; So far only 8bit byte and character IO works ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(in-package :gray-stream) + +(defvar *default-input-buffer-size* 8192) +(defvar *default-output-buffer-size* 8192) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defstruct buffer-state + (input-buffer (make-array *default-input-buffer-size* :element-type '(unsigned-byte 8)) :type (simple-array (unsigned-byte 8) (*))) + (input-index nil) + (input-limit *default-input-buffer-size* :type fixnum) + (output-buffer (make-array *default-output-buffer-size* :element-type '(unsigned-byte 8)) :type (simple-array (unsigned-byte 8) (*))) + (output-index 0) + (output-limit *default-output-buffer-size* :type fixnum))) + +;; Can be used to implement resourcing of buffers later +(defun %allocate-buffer-state (&optional (input-limit *default-input-buffer-size*) (output-limit *default-output-buffer-size*)) + (declare (ignore input-limit output-limit)) + (make-buffer-state)) + +(defun %deallocate-buffer-state (state) + (declare (ignore state))) + +;; Can be used to implement unbuffered encapsulating streams later +(defclass native-lisp-stream-mixin () + ((lisp-stream :initarg :lisp-stream + :reader native-lisp-stream)) + (:documentation "Stream mixin that encapsulates a native stream.")) + +(defclass buffered-stream-mixin (native-lisp-stream-mixin) + ((buffer-state :initform (%allocate-buffer-state))) + (:documentation "Stream mixin that provides buffering for a native lisp stream.")) + +;; fundamental-bivalent-xxx-streams can be used to implement buffered +;; and unbuffered bivalent streams. At the moment, we only implement +;; buffered ones. +(defclass fundamental-bivalent-input-stream + (fundamental-character-input-stream fundamental-binary-input-stream) + ()) + +(defclass fundamental-bivalent-output-stream + (fundamental-character-output-stream fundamental-binary-output-stream) + ()) + +(defclass buffered-bivalent-input-stream + (buffered-stream-mixin fundamental-bivalent-input-stream) + ()) + +(defclass buffered-bivalent-output-stream + (buffered-stream-mixin fundamental-bivalent-output-stream) + ()) + +(defclass buffered-bivalent-stream + (buffered-bivalent-input-stream buffered-bivalent-output-stream) + ()) + +(defmacro with-stream-output-buffer ((buffer index limit) stream &body forms) + (let ((state (gensym "BUFFER-STATE-"))) + `(let ((,state (slot-value ,stream 'buffer-state))) + (symbol-macrolet ((,buffer ,(list 'buffer-state-output-buffer state)) + (,index ,(list 'buffer-state-output-index state)) + (,limit ,(list 'buffer-state-output-limit state))) + ,@forms)))) + +;;; Encapsulated native streams + +(defmethod close ((stream native-lisp-stream-mixin) &key abort) + (close (native-lisp-stream stream) :abort abort)) + +(defmethod stream-listen ((stream native-lisp-stream-mixin)) + (listen (native-lisp-stream stream))) + +(defmethod open-stream-p ((stream native-lisp-stream-mixin)) + (common-lisp::open-stream-p (native-lisp-stream stream))) + +(defmethod stream-clear-output ((stream native-lisp-stream-mixin)) + (clear-output (native-lisp-stream stream))) + +;;; Input streams + +(declaim (inline %reader-function-for-sequence)) +(defun %reader-function-for-sequence (sequence) + (typecase sequence + (string #'read-char) + ((array unsigned-byte (*)) #'read-byte) + ((array signed-byte (*)) #'read-byte) + (otherwise #'read-byte))) + +(defun read-elements (socket-stream sequence start end reader-fn) + (let* ((len (length sequence)) + (chars (- (min (or end len) len) start))) + (loop for i upfrom start + repeat chars + for char = (funcall reader-fn socket-stream) + if (eq char :eof) do (return-from read-elements i) + do (setf (elt sequence i) char)) + (+ start chars))) + +(defmacro with-stream-input-buffer ((buffer index limit) stream &body forms) + (let ((state (gensym "BUFFER-STATE-"))) + `(let ((,state (slot-value ,stream 'buffer-state))) + (symbol-macrolet ((,buffer ,(list 'buffer-state-input-buffer state)) + (,index ,(list 'buffer-state-input-index state)) + (,limit ,(list 'buffer-state-input-limit state))) + ,@forms)))) + +(defgeneric stream-fill-buffer (stream)) +(defmethod stream-fill-buffer ((stream buffered-stream-mixin)) + ;; Implement b/nb semantics: block until at least one byte is read, + ;; but not until the whole buffer is filled. This means it takes at + ;; most n calls to this function to fill a buffer of length n, even + ;; with a slow connection. + (with-stream-input-buffer (buffer index limit) stream + (let* ((the-stream (native-lisp-stream stream)) + (read-bytes + (loop with byte + for n-read from 0 below limit + while (and (if (< 0 n-read) (listen the-stream) t) + (setf byte (read-byte the-stream nil nil))) + do (setf (aref buffer n-read) byte) + count t))) + (if (zerop read-bytes) + nil + (setf index 0 + limit read-bytes))))) + +(defmethod stream-read-byte ((stream buffered-bivalent-input-stream)) + (with-stream-input-buffer (buffer index limit) stream + (unless (and index (< index limit)) + (when (null (stream-fill-buffer stream)) + (return-from stream-read-byte :eof))) + (prog1 (aref buffer index) + (incf index)))) + +(defmethod stream-read-char ((stream buffered-bivalent-input-stream)) + (let ((byte (stream-read-byte stream))) + (if (eq byte :eof) + :eof + (code-char byte)))) + +(defmethod stream-read-char-no-hang ((stream buffered-bivalent-input-stream)) + (if (listen stream) + (read-char stream) + nil)) + +(defmethod stream-unread-char ((stream buffered-bivalent-input-stream) character) + (with-stream-input-buffer (buffer index limit) stream + (let ((new-index (1- index))) + (when (minusp new-index) + (error "Cannot unread char ~A" character)) + (setf (aref buffer new-index) (char-code character) + index new-index))) + nil) + +(defmethod stream-peek-char ((stream buffered-bivalent-input-stream)) + (let ((char (stream-read-char stream))) + (unless (eq char :eof) + (stream-unread-char stream char)) + char)) + + +(defmethod stream-read-line ((stream buffered-bivalent-input-stream)) + (let ((res (make-array 80 :element-type 'character :fill-pointer 0))) + (loop + (let ((ch (stream-read-char stream))) + (cond ((eq ch :eof) + (return (values (copy-seq res) t))) + ((char= ch #\Linefeed) + (return (values (copy-seq res) nil))) + (t + (vector-push-extend ch res))))))) + + +(defmethod stream-read-sequence ((stream buffered-bivalent-input-stream) sequence &optional start end) + (read-elements stream sequence start end (%reader-function-for-sequence sequence))) + +;;(defmethod stream-clear-input ((stream buffered-bivalent-input-stream)) +;; (clear-input (native-lisp-stream stream))) + +(defmethod stream-element-type ((stream fundamental-bivalent-input-stream)) + '(or character (unsigned-byte 8))) + +;;; Output streams + +(declaim (inline %writer-function-for-sequence)) +(defun %writer-function-for-sequence (sequence) + (typecase sequence + (string #'stream-write-char) + ((array unsigned-byte (*)) #'stream-write-byte) + ((array signed-byte (*)) #'stream-write-byte) + (otherwise #'stream-write-byte))) + +(defun write-elements (stream sequence start end writer-fn) + (let* ((len (length sequence)) + (start (or start 0)) + (end (or end len))) + (assert (<= 0 start end len)) + (etypecase sequence + (simple-vector (loop for i from start below end + do (funcall writer-fn stream (svref sequence i)))) + (vector (loop for i from start below end + do (funcall writer-fn stream (aref sequence i)))) + (list (loop for i from start below end + for c in (nthcdr start sequence) + do (funcall writer-fn stream c)))))) + +(defgeneric stream-write-buffer (stream buffer start end)) +(defmethod stream-write-buffer ((stream buffered-stream-mixin) buffer start end) + (let ((lisp-stream (native-lisp-stream stream))) + (write-sequence buffer lisp-stream :start start :end end))) + +(defgeneric stream-flush-buffer (stream)) +(defmethod stream-flush-buffer ((stream buffered-stream-mixin)) + (with-stream-output-buffer (buffer index limit) stream + (when (plusp index) + (stream-write-buffer stream buffer 0 index) + (setf index 0)))) + +(defmethod stream-write-byte ((stream buffered-bivalent-output-stream) byte) + (with-stream-output-buffer (buffer index limit) stream + (unless (< index limit) + (stream-flush-buffer stream)) + (setf (aref buffer index) byte) + (incf index))) + +(defmethod stream-write-char ((stream buffered-bivalent-output-stream) character) + (stream-write-byte stream (char-code character))) + +(defmethod stream-write-string ((stream buffered-bivalent-output-stream) string &optional (start 0) end) + (write-elements stream string start end #'stream-write-char)) + +(defmethod stream-write-sequence ((stream buffered-stream-mixin) sequence + &optional (start 0) end) + (write-elements stream sequence start end (%writer-function-for-sequence sequence))) + +(defmethod stream-element-type ((stream fundamental-bivalent-output-stream)) + '(or character (unsigned-byte 8))) + +(defmethod stream-line-column ((stream fundamental-bivalent-output-stream)) + nil) + +(defmethod stream-finish-output ((stream buffered-bivalent-output-stream)) + (stream-flush-buffer stream) + (finish-output (native-lisp-stream stream))) + +(defmethod stream-force-output ((stream buffered-bivalent-output-stream)) + (stream-flush-buffer stream) + (force-output (native-lisp-stream stream))) + +(defmethod stream-clear-output ((stream buffered-bivalent-output-stream)) + (with-stream-output-buffer (buffer index limit) stream + (setf index 0 + limit 0)) + (call-next-method) ; Clear native stream also + ) + + Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-excl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-excl.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,168 @@ +;;;; +;;;; ACL-COMPAT - EXCL +;;;; + +;;;; Implementation-specific parts of acl-compat.excl (see +;;;; acl-excl-common.lisp) + +(in-package :acl-compat.excl) + +;#-openmcl +;(defun fixnump (x) +; (ccl::fixnump x)) + +#-openmcl +(import 'ccl::fixnump) + +#+openmcl +(defun filesys-inode (path) + (or (nth-value 4 (ccl::%stat (ccl::native-translated-namestring path))) + (error "path ~s does not exist" path))) + +(defun cl-internal-real-time () + (round (/ (get-internal-real-time) 1000))) + +(defun stream-input-fn (stream) + stream) + +(defun filesys-type (file-or-directory-name) + (if (ccl:directory-pathname-p file-or-directory-name) + :directory + (if (probe-file file-or-directory-name) + :file + nil))) + +(defmacro atomically (&body forms) + `(ccl:without-interrupts ,@forms)) + +(defmacro without-package-locks (&body forms) + `(progn ,@forms)) + +(define-condition stream-error (error) + ((stream :initarg :stream + :reader stream-error-stream) + (action :initarg :action + :initform nil + :reader stream-error-action) + (code :initarg :code + :initform nil + :reader stream-error-code) + (identifier :initarg :identifier + :initform nil + :reader stream-error-identifier)) + (:report (lambda (condition stream) + (format stream "A stream error occured (action=~A identifier=~A code=~A stream=~S)." + (stream-error-action condition) + (stream-error-identifier condition) + (stream-error-code condition) + (stream-error-stream condition))))) + +(define-condition socket-error (stream-error) + () + (:report (lambda (condition stream) + (format stream "A socket error occured (action=~A identifier=~A code=~A stream=~S)." + (stream-error-action condition) + (stream-error-identifier condition) + (stream-error-code condition) + (stream-error-stream condition))))) + + + +;! Need to figure out what to do here +(defun fasl-read (filename) + (declare (ignore filename)) + (error "fasl-read not implemented for MCL.") ) + +(defun fasl-write (data stream opt) + (declare (ignore data stream opt)) + (error "fasl-write not implemented for MCL.") ) + + +(defmacro schedule-finalization (object function) + `(ccl:terminate-when-unreachable ,object ,function)) + +(defun run-shell-command (program + &key input output error-output separate-streams + if-input-does-not-exist if-output-exists + if-error-output-exists wait environment show-window) + (declare (ignore show-window)) + ;; KLUDGE: split borrowed from asdf, this shouldn't be done -- it + ;; would be better to use split-sequence or define one ourselves ... + ;; TODO: On Unix, acl also handles a vector of simple-strings as + ;; value for program, with different semantics. + (let* ((program-and-arguments + (delete "" (asdf::split program) :test #'string=)) + (program (car program-and-arguments)) + (arguments (cdr program-and-arguments))) + (when environment + #-unix (error "Don't know how to run program in an environment.") + (setf arguments (append + (list "-i") + (loop for (name . value) in environment + collecting (concatenate 'string name "=" value)) + (list program) + arguments)) + (setf program "env")) + + (let* ((process (run-program program arguments + :input input + :if-input-does-not-exist + if-input-does-not-exist + :output output + :if-output-exists if-output-exists + :error error-output + :if-error-exists if-error-output-exists + :wait wait)) + (in-stream (external-process-input-stream process)) + (out-stream (external-process-output-stream process)) + (err-stream (external-process-error-stream process)) + (pid (external-process-id process))) + (cond + ;; one value: exit status + (wait (nth-value 1 (external-process-status process))) + ;; four values: i/o/e stream, pid + (separate-streams + (values (if (eql input :stream) in-stream nil) + (if (eql output :stream) out-stream nil) + (if (eql error-output :stream) err-stream nil) + pid)) + ;; three values: normal stream, error stream, pid + (t (let ((normal-stream + (cond ((and (eql input :stream) (eql output :stream)) + (make-two-way-stream in-stream out-stream)) + ((eql input :stream) in-stream) + ((eql output :stream) out-stream) + (t nil))) + (error-stream (if (eql error-output :stream) err-stream nil))) + (values normal-stream error-stream pid))))))) + +(defun string-to-octets (string &key (null-terminate t) (start 0) + end mb-vector make-mb-vector? + (external-format :default)) + "This function returns a lisp-usb8-vector and the number of bytes copied." + (declare (ignore external-format)) + ;; The end parameter is different in ACL's lambda list, but this + ;; variant lets us give an argument :end nil explicitly, and the + ;; right thing will happen + (unless end (setf end (length string))) + (let* ((number-of-octets (if null-terminate (1+ (- end start)) + (- end start))) + (mb-vector (cond + ((and mb-vector (>= (length mb-vector) number-of-octets)) + mb-vector) + ((or (not mb-vector) make-mb-vector?) + (make-array (list number-of-octets) + :element-type '(unsigned-byte 8) + :initial-element 0)) + (t (error "Was given a vector of length ~A, ~ + but needed at least length ~A." + (length mb-vector) number-of-octets))))) + (declare (type (simple-array (unsigned-byte 8) (*)) mb-vector)) + (loop for from-index from start below end + for to-index upfrom 0 + do (progn + (setf (aref mb-vector to-index) + (char-code (aref string from-index))))) + (when null-terminate + (setf (aref mb-vector (1- number-of-octets)) 0)) + (values mb-vector number-of-octets))) Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-mp.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-mp.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,183 @@ +;;; This file implements the process functions for AllegroServe in MCL. +;;; Based on the the work done for cmucl and Lispworks. +;;; +;;; John DeSoi, Ph.D. desoi(a)users.sourceforge.net + + +(in-package :acl-compat.mp) + +(eval-when (:compile-toplevel :load-toplevel :execute) + +; existing stuff from ccl we can reuse directly +(shadowing-import + '(ccl:*current-process* + ccl::lock + ccl:process-allow-schedule + ccl:process-name + ccl:process-preset + #-openmcl-native-threads ccl:process-run-reasons + ccl:process-wait + ccl:process-wait-with-timeout + ccl:without-interrupts)) +) + +(eval-when (:compile-toplevel :load-toplevel :execute) + +(export + '(*current-process* + lock + process-allow-schedule + process-name + process-preset + process-run-reasons + process-wait + process-wait-with-timeout + without-interrupts)) +) + +(eval-when (:compile-toplevel :load-toplevel :execute) + +(defmacro without-scheduling (&body forms) + `(ccl:without-interrupts ,@forms)) + +#| +; more ideas stolen from acl-mp-lw.lisp +(defun invoke-with-timeout (seconds bodyfn timeoutfn) + (block timeout + (let* ((process *current-process*) + (timer (ccl:process-run-function "with-timeout-timer" + #'(lambda () + (sleep seconds) + (ccl:process-interrupt process + #'(lambda () + (return-from timeout + (funcall timeoutfn)))))))) + (unwind-protect (funcall bodyfn) + (ccl:process-kill timer))))) + +|# + + + +(defun invoke-with-timeout (seconds bodyfn timeoutfn) + (block timeout + (let* ((timer (ccl::make-timer-request + seconds + #'(lambda () (return-from timeout (funcall timeoutfn)))))) + (ccl::enqueue-timer-request timer) + (unwind-protect (funcall bodyfn) + (ccl::dequeue-timer-request timer))))) + + +(defmacro with-timeout ((seconds &body timeout-forms) &body body) + "Execute BODY; if execution takes more than SECONDS seconds, terminate and evaluate TIMEOUT-FORMS." + `(invoke-with-timeout ,seconds #'(lambda () ,@body) + #'(lambda () ,@timeout-forms))) + + +#+openmcl-native-threads +(progn + +;;; The :INITIAL-BINDINGS arg to process creation functions seems to be +;;; quoted, even when it appears in a list (as in the case of +;;; (process-run-function <args>)) By the time that percolates down +;;; to OpenMCL's process creation functions, it should lose the quote. +;;; +;;; Perhaps I imagined that ... +;;; + +(defun ccl::openmcl-fix-initial-bindings (initial-bindings) + (if (and (consp initial-bindings) + (eq (car initial-bindings) 'quote)) + (cadr initial-bindings) + initial-bindings)) + +) + + +#-openmcl-native-threads +(defmacro process-revoke-run-reason (process reason) + `(ccl:process-disable-run-reason ,process ,reason) ) + +#-openmcl-native-threads +(defmacro process-add-run-reason (process reason) + `(ccl:process-enable-run-reason ,process ,reason) ) + + +(defmacro make-process-lock (&key name) + (if name + `(ccl:make-lock ,name) + `(ccl:make-lock))) + +(defmacro with-process-lock ((lock &key norecursive timeout whostate) &body forms) + (declare (ignore norecursive whostate timeout)) + `(ccl:with-lock-grabbed (,lock) ,@forms)) + + +(defmacro process-kill (process) + `(progn + #-openmcl-native-threads + (unless (ccl:process-active-p ,process) ;won't die unless enabled + (ccl:process-reset-and-enable ,process) ) + (ccl:process-kill ,process))) +) + +(defun process-active-p (process) + (ccl::process-active-p process)) + +(defun interrupt-process (process function &rest args) + "Run FUNCTION in PROCESS." +(apply #'ccl:process-interrupt process function args)) + +(defun current-process () + "The current process." + ccl:*current-process*) + + +;property list implementation from acl-mp-cmu.lisp +(defvar *process-plists* (make-hash-table :test #'eq) + "maps processes to their plists. +See the functions process-plist, (setf process-plist).") + +(defun process-property-list (process) + (gethash process *process-plists*)) + +(defun (setf process-property-list) (new-value process) + (setf (gethash process *process-plists*) new-value)) + +; from acl-mp-lw.lisp +(defun make-process (&key (name "Anonymous") reset-action run-reasons arrest-reasons (priority 0) quantum + resume-hook suspend-hook initial-bindings run-immediately) + (declare (ignore priority quantum reset-action resume-hook suspend-hook run-immediately)) + #-openmcl-native-threads + (declare (ignore initial-bindings)) ;! need separate lexical bindings for each process? + #+openmcl-native-threads + (declare (ignore run-reasons arrest-reasons)) + ;(let ((acl-mp:*process-initial-bindings* initial-bindings)) + #-openmcl-native-threads + (ccl:make-process name :run-reasons run-reasons :arrest-reasons arrest-reasons) + #+openmcl-native-threads + (ccl:make-process name :initial-bindings (ccl::openmcl-fix-initial-bindings initial-bindings))) + +(defun process-run-function (name-or-options preset-function &rest preset-arguments) + (let ((process (ctypecase name-or-options + (string (acl-mp:make-process :name name-or-options)) + (list (apply #'acl-mp:make-process name-or-options))))) + (apply #'acl-mp:process-preset process preset-function preset-arguments) + #+openmcl-native-threads (ccl:process-enable process) + #-openmcl-native-threads (process-add-run-reason process :enable) + process)) + +;;; Busy-waiting ... +(defun wait-for-input-available (streams + &key (wait-function #'ccl:stream-listen) + whostate timeout) + (let ((collected-fds nil)) + (flet ((collect-fds () + (setf collected-fds + (remove-if-not wait-function streams)))) + + (if timeout + (process-wait-with-timeout (or whostate "Waiting for input") timeout #'collect-fds) + (process-wait (or whostate "Waiting for input") #'collect-fds))) + collected-fds)) Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-socket-mcl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-socket-mcl.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,268 @@ +;;; MCL layer for ACL sockets. +;;; Based on acl-socket-cmu.lisp and acl-socket-lw.lisp. +;;; +;;; John DeSoi, Ph.D. desoi(a)users.sourceforge.net + + +(defpackage :acl-compat.socket + (:nicknames :socket :acl-socket) + (:use :common-lisp) + (:export #:make-socket + #:accept-connection + #:ipaddr-to-dotted + #:dotted-to-ipaddr + #:ipaddr-to-hostname + #:lookup-hostname + #:remote-host + #:remote-port + #:local-host + #:local-port + #:socket-control + )) + +(in-package :socket) + +(eval-when (:compile-toplevel :load-toplevel :execute) + +(require :opentransport) + +;OpenTransport.lisp does not export anything, so do this to make it look a bit cleaner. +(import '(ccl::open-tcp-stream + ccl::opentransport-tcp-stream + ccl::opentransport-binary-tcp-stream + ccl::stream-local-port + ccl::stream-local-host + ccl::stream-local-port + ccl::stream-remote-host + ccl::stream-remote-port + ccl::inet-host-name + ccl::tcp-host-address + ) ) + +(defmacro connection-state (s) + `(ccl::opentransport-stream-connection-state ,s)) + +(defmacro connection-established (s) + `(eq :dataxfer (connection-state ,s)) ) + +) + + +;;; There is a bug in MCL (4.3.1 tested) where read-sequence and +;;; write-sequence fail with binary tcp streams. These two methods +;;; provide a work-around. +#-carbon-compat ;should be fixed starting with first carbon version (4.3.5) +(defmethod ccl:stream-write-sequence ((s opentransport-binary-tcp-stream) + (sequence ccl::simple-unsigned-byte-vector) + &key (start 0) end) + (ccl::stream-write-vector s sequence start (or end (length sequence))) + s) + + + +#-carbon-compat ;should be fixed starting with first carbon version (4.3.5) +(defmethod ccl:stream-read-sequence ((s opentransport-binary-tcp-stream) + (sequence ccl::simple-unsigned-byte-vector) + &key (start 0) (end (length sequence))) + (ccl::stream-read-bytes-to-vector s sequence (- end start) start) + end) + + + +(defmethod port ((stream opentransport-tcp-stream)) + (stream-local-port stream) ) + +(defmethod local-host ((s opentransport-tcp-stream)) + (stream-local-host s)) + +(defmethod local-port ((s opentransport-tcp-stream)) + (stream-local-port s)) + +(defmethod remote-host ((s opentransport-tcp-stream)) + (stream-remote-host s)) + +(defmethod remote-port ((s opentransport-tcp-stream)) + (stream-remote-port s)) + +;? copied from lispworks - don't think it applies to mcl +(defmethod fd ((s opentransport-tcp-stream)) + (declare (ignore s)) + 42) + + + +(defvar *passive-socket-listener-count* 10 + "Default number of listen streams to use.") + +; With ACL, an unlimited number of connections can be made to the same passive +; socket instance. Nothing like that here, so we have to create our own stream +; listener to create the "real" sockets as connections are made. + + +; Create a class to monitor streams so we have a data structure to pass to process-wait +(defclass passive-socket (stream) ;inherit stream so we can handle close + ((port + :documentation "Port we are listening on." + :initform 80 + :initarg :port + :reader local-port) + (element-type + :documentation "Stream element type." + :initarg :element-type + :initform '(unsigned-byte 8)) + (count + :documentation "Number of listening streams to monitor." + :initform *passive-socket-listener-count*) + (streams + :documentation "Array of listen streams." + :initform nil) + (index + :documentation "Index of the last listen stream checked." + :initform *passive-socket-listener-count*) + (connect-index + :documentation "Index of a connected stream, next for processing." + :initform nil) + ) + (:documentation "Class used to manage listening streams and connections.") ) + + + +(defmethod initialize-instance :after ((listener passive-socket) &rest initargs) + (declare (ignore initargs)) + (with-slots (streams count port element-type) listener + (setf streams (make-array count :initial-element nil :adjustable t)) + (dotimes (i count) + (setf (elt streams i) (new-listen-stream listener)) ) ) ) + + +(defmethod ccl:stream-close ((listener passive-socket)) + (with-slots (streams count) listener + (dotimes (i count) + (close (elt streams i))) + (setf count 0))) + + +(defmethod new-listen-stream ((listener passive-socket)) + (with-slots (port element-type) listener + (open-tcp-stream nil port ;use nil host to get a passive connection + :element-type element-type) ) ) + + +(defmethod local-host ((listener passive-socket)) + (with-slots (streams count) listener + (when (> count 0) + (local-host (elt streams 0))))) + + + +; See if one of the streams is established. +(defmethod find-connection-index ((listener passive-socket)) + (with-slots (count streams index connect-index) listener + (let ((next (if (< (1+ index) count) (1+ index) 0))) + (when (connection-established (elt streams next)) + (setf index next + connect-index next) + connect-index)))) + + +(defmethod process-connected-stream ((listener passive-socket)) + (with-slots (streams connect-index) listener + (if (null connect-index) nil + (let ((s (elt streams connect-index))) ;return the connected stream and set a new one + (setf (elt streams connect-index) (new-listen-stream listener)) + (setf connect-index nil) + s) ) ) ) + + +;! future - determine how many connects we are getting an dynamically increase the number +; of listeners if necessary. +(defmethod accept-connection ((listener passive-socket) &key (wait t)) + (if wait + (ccl:process-wait "accept connection..." #'find-connection-index listener) ;apply repeatedly with process wait + (find-connection-index listener) ) + (process-connected-stream listener) ) + + +(defun make-socket (&key (remote-host "localhost") + local-port + remote-port + (connect :active) + (format :text) + &allow-other-keys) + (let ((element-type (ecase format + (:text 'base-char) + (:binary 'signed-byte) + (:bivalent 'unsigned-byte)))) + (ecase connect + (:passive + (make-instance 'passive-socket :port local-port :element-type element-type :direction :io)) + (:active + (let ((host (if (integerp remote-host) ;aparently the acl version also accepts an integer + (ipaddr-to-dotted remote-host) + remote-host))) + (check-type host string) + (open-tcp-stream host remote-port + :element-type element-type)))))) + + + +(declaim (ftype (function ((unsigned-byte 32)) (values simple-string)) + ipaddr-to-dotted)) + +(defun ipaddr-to-dotted (ipaddr &key values) + (declare (type (unsigned-byte 32) ipaddr)) + (let ((a (logand #xff (ash ipaddr -24))) + (b (logand #xff (ash ipaddr -16))) + (c (logand #xff (ash ipaddr -8))) + (d (logand #xff ipaddr))) + (if values + (values a b c d) + (format nil "~d.~d.~d.~d" a b c d)))) + +(defun string-tokens (string) + (labels ((get-token (str pos1 acc) + (let ((pos2 (position #\Space str :start pos1))) + (if (not pos2) + (nreverse acc) + (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2)) + acc)))))) + (get-token (concatenate 'string string " ") 0 nil))) + +(declaim (ftype (function (string &key (:errorp t)) + (values (unsigned-byte 32))) + dotted-to-ipaddr)) + +(defun dotted-to-ipaddr (dotted &key (errorp t)) + (declare (string dotted)) + (if errorp + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll))) + (ignore-errors + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll)))))) + +(defun ipaddr-to-hostname (ipaddr &key ignore-cache) + (declare (ignore ignore-cache)) + (inet-host-name ipaddr) ) + +(defun lookup-hostname (host &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported.")) + (if (stringp host) + (tcp-host-address host) + (dotted-to-ipaddr (ipaddr-to-dotted host)))) + + +(defun socket-control (stream &key output-chunking output-chunking-eof input-chunking) + (declare (ignore stream)) + (warn "SOCKET-CONTROL function not implemented.") + (when (or output-chunking output-chunking-eof input-chunking) + (error "Chunking is not yet supported in MCL. Restart the server with argument :chunking nil (turns chunking off).") ) ) + + +(provide 'acl-socket) + + + Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-socket-openmcl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-socket-openmcl.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,145 @@ +;;; OpenMCL layer for ACL sockets. +;;; Most everything is already there, just needs to be in the socket package. +;;; +;;; John DeSoi, Ph.D. desoi(a)users.sourceforget.net + +(in-package :acl-compat.socket) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (shadowing-import + '(;ccl:make-socket ; use our own version + ccl:accept-connection + ccl:dotted-to-ipaddr + ccl:ipaddr-to-hostname + ccl:lookup-hostname + ccl:remote-host + ccl:remote-port + ccl:local-host + ccl:local-port)) +) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (export + '(accept-connection + ipaddr-to-dotted + dotted-to-ipaddr + ipaddr-to-hostname + lookup-hostname + remote-host + remote-port + local-host + local-port + socket-control)) + ) + + +(defclass server-socket () + ((socket :initarg :socket :reader socket + :initform (error "No value supplied for socket")) + (port :initarg :port + :reader port + :initform (error "No value supplied for port")))) + + +(defmethod print-object ((socket server-socket) stream) + (print-unreadable-object (socket stream :type t :identity nil) + (format stream "listening on port ~d" (port socket)))) + + +(defmethod accept-connection ((server-socket server-socket) + &key (wait t)) + "Return a bidirectional stream connected to socket." + (let ((stream (accept-connection (socket server-socket) :wait wait))) + (when stream (make-chunked-stream stream)))) + + +(defun make-socket (&rest args + &key (connect :active) port + &allow-other-keys) + "Return a stream connected to remote-host if connect is :active, or +something listening on local-port that can be fed to accept-connection +if connect is :passive. +" + (let ((socket-or-stream (apply #'ccl:make-socket args))) + (if (eq connect :active) + (make-chunked-stream socket-or-stream) + (make-instance 'server-socket :socket socket-or-stream :port port)))) + + +(defmethod close ((server-socket server-socket) &key abort) + "Kill a passive (listening) socket. (Active sockets are actually +streams and handled by their close methods." + (declare (ignore abort)) + (close (socket server-socket))) + +(defmethod local-host ((server-socket server-socket)) + (local-host (socket server-socket))) + +(defmethod local-port ((server-socket server-socket)) + (local-port (socket server-socket))) + +(defmethod ccl:stream-write-vector + ((stream gray-stream::buffered-bivalent-stream) vector start end) + (declare (fixnum start end)) + (let ((fn (gray-stream::%writer-function-for-sequence vector))) + (do* ((i start (1+ i))) + ((= i end)) + (declare (fixnum i)) + (funcall fn stream (ccl:uvref vector i))))) + +(defmethod ccl:stream-read-vector + ((stream gray-stream::buffered-bivalent-stream) vector start end) + (declare (fixnum start end)) + (let ((fn (gray-stream::%reader-function-for-sequence vector))) + (do* ((i start (1+ i))) + ((= i end) end) + (declare (fixnum i)) + (let* ((b (funcall fn stream))) + (if (eq b :eof) + (return i) + (setf (ccl:uvref vector i) b)))))) + +(defclass chunked-stream (de.dataheaven.chunked-stream-mixin::chunked-stream-mixin + gray-stream::buffered-bivalent-stream) + ((plist :initarg :plist :accessor stream-plist))) + +(defun make-chunked-stream (lisp-stream &key plist) + (make-instance 'chunked-stream :lisp-stream lisp-stream :plist plist)) + +(defmethod local-host ((chunked-stream chunked-stream)) + (local-host (gray-stream::native-lisp-stream chunked-stream))) + +(defmethod local-port ((chunked-stream chunked-stream)) + (local-port (gray-stream::native-lisp-stream chunked-stream))) + +(defmethod remote-host ((chunked-stream chunked-stream)) + (remote-host (gray-stream::native-lisp-stream chunked-stream))) + +(defmethod remote-port ((chunked-stream chunked-stream)) + (remote-port (gray-stream::native-lisp-stream chunked-stream))) + + +(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p)) + (when oc-p + (when output-chunking + (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin::output-chunking-p stream) + output-chunking)) + (when output-chunking-eof + (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream)) + (when ic-p + (when input-chunking + (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin::input-chunking-p stream) + input-chunking))) + +; OpenMCL has a built-in ipaddr-to-dotted. But it appears that sometimes +; the log function is being called after the connection is closed and +; it causes nil to be passed to ipaddr-to-dotted. So we wrap ipaddr-to-dotten +; to ensure only non-nil values are passed. + +(defun ipaddr-to-dotted (ipaddr &key values) + (unless (null ipaddr) + (ccl:ipaddr-to-dotted ipaddr :values values))) + +(provide 'acl-socket) Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-sys.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-sys.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,20 @@ + +(in-package :acl-compat.system) + + +(defun command-line-arguments () + #+openmcl (ccl::command-line-arguments) + #-openmcl nil) + +(defun command-line-argument (n) + #+openmcl (nth n (command-line-arguments)) + #-openmcl nil) + +;;; On acl, reap-os-subprocess is needed for (run-shell-command ... +;;; :wait nil), but not on OpenMCL. +(defun reap-os-subprocess (&key (wait nil)) + (declare (ignore wait)) + nil) + +#+nil +(export '(command-line-arguments command-line-argument reap-os-subprocess)) Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/mcl-stream-fix.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/mcl/mcl-stream-fix.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,44 @@ + + +(in-package :ccl) + +;;; There are several bugs in MCL functions to read sequences prior to 4.3.5; this fixes them + + + +(eval-when (:compile-toplevel :load-toplevel :execute) + +(let ((ccl:*warn-if-redefine* nil)) + +(defun %io-buffer-read-bytes-to-vector (io-buffer vector bytes start) + (loop with fill-pointer = start + with bytes-remaining = bytes + until (eql 0 bytes-remaining) + while (if (eql 0 (io-buffer-incount io-buffer)) + (%io-buffer-advance io-buffer t t) ; eof may be signalled through this -- JCMa 5/13/1999. + t) + for buffer = (io-buffer-inptr io-buffer) + for read-bytes = (min (io-buffer-incount io-buffer) bytes-remaining) + do (%copy-ptr-to-ivector buffer 0 vector fill-pointer read-bytes) + (incf fill-pointer read-bytes) + (%incf-ptr (io-buffer-inptr io-buffer) read-bytes) ;; bug fix from akh on 7/28/2002 + (decf bytes-remaining read-bytes) + (decf (io-buffer-incount io-buffer) read-bytes) + (incf (io-buffer-bytes-read io-buffer) read-bytes))) + + +;This function is unchanged, but kept for completeness +(defun io-buffer-read-bytes-to-vector (io-buffer vector bytes &optional (start 0)) + (require-type io-buffer 'io-buffer) + (with-io-buffer-locked (io-buffer) + (multiple-value-bind (v v-offset) + (array-data-and-offset vector) + (%io-buffer-read-bytes-to-vector io-buffer v bytes (+ start v-offset))))) + + +(defmethod stream-read-bytes-to-vector ((stream buffered-output-stream-mixin) vector bytes &optional (start 0)) + (io-buffer-read-bytes-to-vector (stream-io-buffer stream) vector bytes start)) ;original fuction did not get the buffer from the stream + + +) +) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/mcl-timers.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/mcl/mcl-timers.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,112 @@ +;;; mcl-timers contributed by Gary Byers + +(in-package "CCL") + + +;;; A simple timer mechanism for MCL/OpenMCL, which uses a +;;; PERIODIC-TASK to check for expired "timer requests". +;;; In MCL and OpenMCL, PERIODIC-TASKS run at specified +;;; intervals via the same preemption mechanism that the +;;; scheduler uses; they run in the execution context of +;;; whatever thread was preempted, and they're assumed to +;;; run pretty quickly. +;;; This code uses doubly-linked-list elements (DLL-NODEs) +;;; to represent a sorted list of "timer requests"; client +;;; processes use timer requests to schedule an interrupt +;;; action at a specified time. A periodic task walks this +;;; list once a second (by default), removing those requests +;;; whose time isn't in the future and interrupting the +;;; corresponding processes. + + +;;; The number of timer interrupts (ticks) per second. +(defmacro ticks-per-second () + #+OpenMCL '*ticks-per-second* + #-OpenMCL 60) + + +(defun expiration-tick-count (seconds) + (+ (round (* seconds (ticks-per-second))) + (get-tick-count))) + +(defstruct (timer-request (:include dll-node) + (:constructor %make-timer-request)) + expiration-tick ; when the timer expires + process ; what process to interrupt + function) ; how to interrupt it + + +(defun make-timer-request (seconds-from-now function) + (check-type seconds-from-now (and unsigned-byte fixnum)) + (check-type function function) + (%make-timer-request + :expiration-tick (expiration-tick-count seconds-from-now) + :process *current-process* + :function function)) + + +;;; the CCL::DEFLOADVAR construct ensures that the variable +;;; will be reinitialized when a saved image is restarted +(defloadvar *timer-request-queue* + #-openmcl-native-threads (make-dll-header) + #+openmcl-native-threads (make-locked-dll-header)) + +;;; Insert the timer request before the first element with a later +;;; expiration time (or at the end of the queue if there's no such +;;; element.) +(defun enqueue-timer-request (r) + (#-openmcl-native-threads without-interrupts + #+openmcl-native-threads with-locked-dll-header + #+openmcl-native-threads (*timer-request-queue*) + (if (dll-node-succ r) ; Already enqueued. + r ; Or signal an error. + (let* ((r-date (timer-request-expiration-tick r))) + (do* ((node *timer-request-queue* next) + (next (dll-node-succ node) (dll-node-succ next))) + ((or (eq next *timer-request-queue*) + (> (timer-request-expiration-tick next) r-date)) + (insert-dll-node-after r node))))))) + +;;; Remove a timer request. (It's a no-op if the request has already +;;; been removed.) +(defun dequeue-timer-request (r) + (#-openmcl-native-threads without-interrupts + #+openmcl-native-threads with-locked-dll-header + #+openmcl-native-threads (*timer-request-queue*) + (when (dll-node-succ r) ;enqueued + (remove-dll-node r)) + r)) + +;;; Since this runs in an arbitrary process, it tries to be a little +;;; careful with requests made by the current process (since running +;;; the interrupt function will probably transfer control out of the +;;; periodic task function.) The oldest (hopefully only) request for +;;; the current process is handled after all other pending requests. +(defun process-timer-requests () + (let* ((now (get-tick-count)) + (current-process *current-process*) + (current-process-action ())) + (#-openmcl-native-threads progn + #+openmcl-native-threads with-locked-dll-header + #+openmcl-native-threads (*timer-request-queue*) + + (do-dll-nodes (r *timer-request-queue*) + (when (> (timer-request-expiration-tick r) now) + (return)) ; Anything remaining is + ; in the future. + (dequeue-timer-request r) + (let* ((proc (timer-request-process r)) + (func (timer-request-function r))) + (if (eq proc current-process) + (if (null current-process-action) + (setq current-process-action func)) + (process-interrupt (timer-request-process r) + (timer-request-function r))))) + (when current-process-action + (funcall current-process-action))))) + +(%install-periodic-task + 'process-timer-requests ; Name of periodic task + 'process-timer-requests ; function to call + (ticks-per-second) ; Run once per second + ) Added: branches/trunk-reorg/thirdparty/acl-compat/packages.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/packages.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,272 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; Package definitions for acl-compat. +;;;; +;;;; Package names follow their Allegro CL counterparts -- for an ACL +;;;; package foo, acl-compat defines a package acl-compat.foo +;;;; +;;;; Some packages have nicknames, which were used as package names by +;;;; previous versions of paserve and acl-compat. The nicknames are +;;;; deprecated, but are kept for the benefit of people using +;;;; acl-compat in other projects. New projects should use the +;;;; package names starting with "acl-compat.". +;;;; + +(in-package :common-lisp-user) + +;;; general +(defpackage :acl-compat.excl + (:use #:common-lisp + #+cmu #:ext + #+clisp #:ext + #+sbcl #:sb-ext #+sbcl #:sb-gray + #+(or allegro cormanlisp) :excl + #+(or mcl openmcl) :ccl + ) + #+lispworks (:import-from :common-lisp #:fixnump) + #+sbcl (:import-from :sb-int #:fixnump) + #+sbcl (:import-from :sb-ext #:without-package-locks) + #+cmu (:import-from :ext #:without-package-locks) + #+allegro (:shadowing-import-from :excl #:filesys-size + #:filesys-write-date #:intern* #:filesys-type #:atomically #:fast) + (:export + #:if* + #:*initial-terminal-io* + #:*cl-default-special-bindings* + #:filesys-size + #:filesys-write-date + #:stream-input-fn + #:match-regexp + #:compile-regexp + #:*current-case-mode* + #:intern* + #:filesys-type + #:errorset + #:atomically + #:fast + #:without-package-locks + #:fixnump + #+(or lispworks mcl openmcl) #:socket-error + #+(or allegro lispworks mcl openmcl) #:run-shell-command + #+(or allegro mcl openmcl) #:fasl-read + #+(or allegro mcl openmcl) #:fasl-write + #+(or allegro cmu scl mcl lispworks openmcl) #:string-to-octets + #+(or allegro cmu scl mcl lispworks openmcl) #:write-vector + )) + + +;; general +(defpackage :acl-compat.mp + (:use :common-lisp #+cormanlisp :acl-compat-mp #+allegro :mp) + (:nicknames :acl-mp #-cormanlisp :acl-compat-mp) + #+allegro (:shadowing-import-from :mp #:process-interrupt #:lock) + #+allegro (:shadowing-import-from :excl #:without-interrupts) + (:export + #:*current-process* ;* + #:process-kill ;* + #:process-preset ;* + #:process-name ;* + + #:process-wait-function + #:process-run-reasons + #:process-arrest-reasons + #:process-whostate + #:without-interrupts + #:process-wait + #:process-enable + #:process-disable + #:process-reset + #:process-interrupt + + #:process-run-function ;* + #:process-property-list ;* + #:without-scheduling ;* + #:process-allow-schedule ;* + #:make-process ;* + #:process-add-run-reason ;* + #:process-revoke-run-reason ;* + #:process-add-arrest-reason ;* + #:process-revoke-arrest-reason ;* + #:process-allow-schedule ;* + #:with-timeout ;* + #:make-process-lock ;* + #:with-process-lock ;* + #:process-lock + #:process-unlock + + #:current-process + #:process-name-to-process + #:process-wait-with-timeout + #:wait-for-input-available + #:process-active-p + )) + +(defpackage :de.dataheaven.chunked-stream-mixin + (:use :common-lisp) + (:export #:chunked-stream-mixin + #:output-chunking-p #:input-chunking-p)) + +;; general +(defpackage acl-compat.socket + (:use #:common-lisp + #+(or cmu lispworks scl) #:acl-mp + #+(or lispworks cmu)#:acl-compat.excl + #+clisp #:socket + #+sbcl #:sb-bsd-sockets + #+(or lispworks cmu) #:de.dataheaven.chunked-stream-mixin + #+cormanlisp #:socket + ) + #+cl-ssl (:import-from :ssl #:MAKE-SSL-CLIENT-STREAM #:MAKE-SSL-SERVER-STREAM) + #+lispworks (:shadow socket-stream stream-error) + (:export + #+(or lispworks cmu) #:socket + #:make-socket + #:accept-connection + #:ipaddr-to-dotted + #:dotted-to-ipaddr + #:ipaddr-to-hostname + #:lookup-hostname + #:remote-host + #:remote-port + #:local-host + #:local-port + #:socket-control + #+cl-ssl #:make-ssl-client-stream + #+cl-ssl #:make-ssl-server-stream + #+(and :lispworks4.4 (not :cl-ssl)) #:make-ssl-client-stream + #+(and :lispworks4.4 (not :cl-ssl)) #:make-ssl-server-stream + #+lispworks #:socket-os-fd + ) + #-cormanlisp (:nicknames #-(or clisp allegro) socket #-allegro acl-socket)) + + +(defpackage acl-compat.system + (:nicknames :acl-compat.sys) + (:use :common-lisp) + (:export + #:command-line-arguments + #:command-line-argument + #:reap-os-subprocess + )) + + +; these are not all in the ccl package which causes an error +#+(and mcl (not openmcl)) +(shadowing-import '( + fundamental-binary-input-stream + fundamental-binary-output-stream + fundamental-character-input-stream + fundamental-character-output-stream + stream-element-type + stream-listen + stream-read-byte + stream-read-char + stream-peek-char + stream-write-byte + stream-write-char + stream-read-char-no-hang + stream-force-output + stream-finish-output + stream-clear-input + stream-clear-output + stream-line-column + stream-read-sequence + stream-unread-char + stream-read-line + stream-write-sequence + stream-write-string) + :ccl) + +#-cormanlisp +(defpackage :gray-stream + (:use #:common-lisp) + (:import-from #+lispworks :stream #+cmu :lisp #+clisp :gray #+cormanlisp :gray-streams + #+(or mcl openmcl) :ccl #+allegro :excl #+sbcl :sb-gray + #:fundamental-binary-input-stream + #:fundamental-binary-output-stream + #:fundamental-character-input-stream + #:fundamental-character-output-stream + #:stream-element-type + #:stream-listen + #:stream-read-byte + #:stream-read-char + #:stream-peek-char + #:stream-write-byte + #:stream-write-char + #:stream-read-char-no-hang + #:stream-force-output + #:stream-finish-output + #:stream-clear-input + #:stream-clear-output + #:stream-line-column + #-(or clisp openmcl) #:stream-read-sequence + #:stream-unread-char + #:stream-read-line + #-(or clisp openmcl) #:stream-write-sequence + #:stream-write-string + #+lispworks #:stream-write-buffer + #+lispworks #:stream-read-buffer + #+lispworks #:stream-fill-buffer + #+lispworks #:stream-flush-buffer + #+lispworks #:with-stream-input-buffer + #+lispworks #:with-stream-output-buffer) + (:export + #:fundamental-binary-input-stream + #:fundamental-binary-output-stream + #:fundamental-character-input-stream + #:fundamental-character-output-stream + #:stream-element-type + #:stream-listen + #:stream-read-byte + #:stream-read-char + #:stream-write-byte + #:stream-write-char + #:stream-read-char-no-hang + #:stream-force-output + #:stream-finish-output + #:stream-clear-input + #:stream-clear-output + #:stream-line-column + #-clisp #:stream-read-sequence + #:stream-unread-char + #:stream-read-line + #-clisp #:stream-write-sequence + #:stream-write-string + #:stream-write-buffer + #:stream-read-buffer + #:stream-fill-buffer + #:stream-flush-buffer + #:with-stream-input-buffer + #:with-stream-output-buffer)) + +#+cormanlisp +(defpackage :gray-stream + (:use #:common-lisp :gray-streams) + (:export + #:fundamental-binary-input-stream + #:fundamental-binary-output-stream + #:fundamental-character-input-stream + #:fundamental-character-output-stream + #:stream-element-type + #:stream-listen + #:stream-read-byte + #:stream-read-char + #:stream-write-byte + #:stream-write-char + #:stream-read-char-no-hang + #:stream-force-output + #:stream-finish-output + #:stream-clear-input + #:stream-clear-output + #:stream-line-column + #:stream-read-sequence + #:stream-unread-char + #:stream-read-line + #:stream-write-sequence + #:stream-write-string + #:stream-write-buffer + #:stream-read-buffer + #:stream-fill-buffer + #:stream-flush-buffer + #:with-stream-input-buffer + #:with-stream-output-buffer)) Added: branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-excl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-excl.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,32 @@ +;;;; +;;;; ACL-COMPAT - EXCL +;;;; + +;;;; Implementation-specific parts of acl-compat.excl (see +;;;; acl-excl-common.lisp) + +(in-package :acl-compat.excl) + +(defun stream-input-fn (stream) + stream) + +(defun filesys-type (file-or-directory-name) + (let ((mode (sb-posix:stat-mode (sb-posix:stat file-or-directory-name)))) + (cond + ((sb-posix:s-isreg mode) :file) + ((sb-posix:s-isdir mode) :directory) + (t nil)))) + +(defmacro atomically (&body forms) + `(acl-mp:without-scheduling ,@forms)) + +(defun unix-signal (signal pid) + (declare (ignore signal pid)) + (error "unix-signal not implemented in acl-excl-sbcl.lisp")) + +(defun filesys-inode (path) + (sb-posix:stat-ino (sb-posix:lstat path))) + +(defun cl-internal-real-time () + (round (/ (get-internal-real-time) internal-time-units-per-second))) + Added: branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-mp.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-mp.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,294 @@ +;; Threading for sbcl, or stub functions for single-threaded sbcl. +;; +;; Written by Rudi Schlatte, intended to be distributed along with the +;; acl-compat library, under the same license as the rest of it. + +;; Inspirations taken from Dan Barlow<dan(a)metacircles.com>'s work for +;; McCLIM; cut, pasted and mutilated with permission. + +(in-package :acl-compat.mp) + +(defstruct (process + (:constructor %make-process) + (:predicate processp)) + name + state + whostate + function ; function wot will be run + arguments ; arguments to the function + id ; pid of unix thread or nil + %lock ; lock for process structure mutators + run-reasons ; primitive mailbox for IPC + %queue ; queue for condition-wait + initial-bindings ; special variable bindings + property-list) + +(defparameter *current-process* + #-sb-thread + (%make-process) + #+sb-thread + ;; We don't fill in the process id, so the process compiling this + ;; (the REPL, in most cases) can't be killed by accident. (loop for + ;; p in (all-processes) do (kill-process p)), anyone? + (%make-process :name "initial process" :function nil)) + +(defparameter *all-processes-lock* + (sb-thread:make-mutex :name "all processes lock")) + +(defparameter *all-processes* + (list *current-process*)) + +#-sb-thread +(defun make-process (&key (name "Anonymous") reset-action run-reasons + arrest-reasons (priority 0) quantum resume-hook + suspend-hook initial-bindings run-immediately) + (declare (ignore reset-action arrest-reasons priority quantum resume-hook + suspend-hook run-immediately)) + (%make-process :name "the only process" + :run-reasons run-reasons + :initial-bindings initial-bindings)) + +#+sb-thread +(defun make-process (&key (name "Anonymous") reset-action run-reasons + arrest-reasons (priority 0) quantum resume-hook + suspend-hook initial-bindings run-immediately) + (declare (ignore reset-action arrest-reasons priority quantum resume-hook + suspend-hook run-immediately)) + (let ((p (%make-process + :name name + :run-reasons run-reasons + :initial-bindings initial-bindings + :%lock (sb-thread:make-mutex + :name (format nil "Internal lock for ~A" name)) + :%queue (sb-thread:make-waitqueue + :name (format nil "Blocking queue for ~A" name))))) + (sb-thread:with-mutex (*all-processes-lock*) + (push p *all-processes*)) + p)) + +(defmacro defun/sb-thread (name args &body body) + #-sb-thread (declare (ignore body)) + `(defun ,name ,args + #-sb-thread + (declare (ignore ,@(remove-if + (lambda (x) + (member x '(&optional &rest &key &allow-other-keys + &aux))) + (mapcar (lambda (x) (if (consp x) (car x) x)) + args)))) + #-sb-thread + (error + "~A: Calling a multiprocessing function on a single-threaded sbcl build" + ',name) + #+sb-thread + ,@body)) + +(defun/sb-thread process-interrupt (process function) + (sb-thread:interrupt-thread (process-id process) function)) + +;; TODO: why no such function was in +sb-thread part? +(defun/sb-thread process-wait-function (process) + (declare (ignore process))) + +(defun/sb-thread process-wait (reason predicate &rest arguments) + (declare (type function predicate)) + (let ((old-state (process-whostate *current-process*))) + (unwind-protect + (progn + (setf old-state (process-whostate *current-process*) + (process-whostate *current-process*) reason) + (loop + (let ((it (apply predicate arguments))) + (when it (return it))) + (process-allow-schedule))) + (setf (process-whostate *current-process*) old-state)))) + +(defun/sb-thread process-allow-schedule (&optional process) + (declare (ignore process)) + (sleep .01)) + +(defun/sb-thread process-revoke-run-reason (process object) + (sb-thread:with-recursive-lock ((process-%lock process)) + (prog1 + (setf (process-run-reasons process) + (delete object (process-run-reasons process))) + (when (and (process-id process) (not (process-run-reasons process))) + (disable-process process))))) + +(defun/sb-thread process-add-run-reason (process object) + (sb-thread:with-recursive-lock ((process-%lock process)) + (prog1 + (push object (process-run-reasons process)) + (if (process-id process) + (enable-process process) + (restart-process process))))) + +(defun/sb-thread process-run-function (name-or-options preset-function + &rest preset-arguments) + (let* ((make-process-args (etypecase name-or-options + (list name-or-options) + (string (list :name name-or-options)))) + (process (apply #'make-process make-process-args))) + (apply #'process-preset process preset-function preset-arguments) + (setf (process-run-reasons process) :enable) + (restart-process process) + process)) + +(defun/sb-thread process-preset (process function &rest arguments) + (setf (process-function process) function + (process-arguments process) arguments) + (when (process-id process) (restart-process process))) + +(defun/sb-thread process-kill (process) + (when (process-id process) + (sb-thread:destroy-thread (process-id process)) + (setf (process-id process) nil)) + (sb-thread:with-mutex (*all-processes-lock*) + (setf *all-processes* (delete process *all-processes*)))) + +#+sb-thread +(defun make-process-lock (&key name) + (sb-thread:make-mutex :name name)) +#-sb-thread +(defun make-process-lock (&key name) + (declare (ignore name)) + nil) + +(defun/sb-thread process-lock (lock &optional lock-value whostate timeout) + (declare (ignore whostate timeout)) + (sb-thread:get-mutex lock lock-value)) + +(defun/sb-thread process-unlock (lock &optional lock-value) + (declare (ignore lock-value)) + (sb-thread:release-mutex lock)) + +#-sb-thread +(defmacro with-process-lock ((lock &key norecursive timeout whostate) + &body forms) + (declare (ignore lock norecursive timeout whostate)) + `(progn ,@forms)) + +#+sb-thread +(defmacro with-process-lock ((place &key timeout whostate norecursive) + &body body) + (declare (ignore norecursive timeout)) + (let ((old-whostate (gensym "OLD-WHOSTATE"))) + `(sb-thread:with-recursive-lock (,place) + (let (,old-whostate) + (unwind-protect + (progn + (when ,whostate + (setf ,old-whostate (process-whostate *current-process*)) + (setf (process-whostate *current-process*) ,whostate)) + ,@body) + (setf (process-whostate *current-process*) ,old-whostate)))))) + + +#-sb-thread +(defmacro without-scheduling (&body forms) + `(progn ,@forms)) ; * + +;;; FIXME but, of course, we can't. Fix whoever wants to use it, +;;; instead +#+sb-thread +(defmacro without-scheduling (&body body) + `(progn ,@body)) + +;;; Same implementation for multi- and uni-thread +(defmacro with-timeout ((seconds &body timeout-forms) &body body) + (let ((c (gensym "TIMEOUT-"))) + `(handler-case + (sb-ext::with-timeout ,seconds (progn ,@body)) + (sb-ext::timeout (,c) (declare (ignore ,c)) ,@timeout-forms)))) + +(defun/sb-thread restart-process (process) + (labels ((boing () + (let ((*current-process* process) + (bindings (process-initial-bindings process)) + (function (process-function process)) + (arguments (process-arguments process))) + (declare (type function function)) + (if bindings + (progv + (mapcar #'car bindings) + (mapcar #'(lambda (binding) + (eval (cdr binding))) + bindings) + (apply function arguments)) + (apply function arguments))))) + (when (process-id process) + (sb-thread:terminate-thread (process-id process))) + ;; XXX handle run-reasons in some way? Should a process continue + ;; running if all run reasons are taken away before + ;; restart-process is called? (process-revoke-run-reason handles + ;; this, so let's say (setf (process-run-reasons process) nil) is + ;; not guaranteed to do the Right Thing.) + (when (setf (process-id process) + (sb-thread:make-thread #'boing :name (process-name process))) + process))) + +(defun current-process () + *current-process*) + +(defun all-processes () + (copy-list *all-processes*)) + +(defun/sb-thread process-wait-with-timeout (reason timeout predicate) + (declare (type function predicate)) + (let ((old-state (process-whostate *current-process*)) + (end-time (+ (get-universal-time) timeout))) + (unwind-protect + (progn + (setf old-state (process-whostate *current-process*) + (process-whostate *current-process*) reason) + (loop + (let ((it (funcall predicate))) + (when (or (> (get-universal-time) end-time) it) + (return it))) + (sleep .01))) + (setf (process-whostate *current-process*) old-state)))) + +(defun/sb-thread disable-process (process) + ;; TODO: set process-whostate + ;; Can't figure out how to safely block a thread from a different one + ;; and handle all the locking nastiness. So punt for now. + (if (eq sb-thread:*current-thread* (process-id process)) + ;; Keep waiting until we have a reason to run. GC and other + ;; things can break a wait prematurely. Don't know if this is + ;; expected or not. + (do () + ((process-run-reasons process) nil) + (sb-thread:with-recursive-lock ((process-%lock process)) + (sb-thread:condition-wait (process-%queue process) + (process-%lock process)))) + (error "Can't safely disable-process from another thread"))) + +(defun/sb-thread enable-process (process) + ;; TODO: set process-whostate + (sb-thread:with-recursive-lock ((process-%lock process)) + (sb-thread:condition-notify (process-%queue process)))) + +;;; TODO: integrate with McCLIM / system-wide queue for such things +#+sb-thread +(defvar *atomic-spinlock* (sb-thread::make-spinlock)) + +#-sb-thread +(defmacro atomic-incf (place) + `(incf ,place)) + +#+sb-thread +(defmacro atomic-incf (place) + `(sb-thread::with-spinlock (*atomic-spinlock*) + (incf ,place))) + +#-sb-thread +(defmacro atomic-decf (place) + `(decf ,place)) + +#+sb-thread +(defmacro atomic-decf (place) + `(sb-thread::with-spinlock (*atomic-spinlock*) + (decf ,place))) + +(defun process-active-p (process) + (sb-thread:thread-alive-p (process-id process))) Added: branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-socket.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-socket.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,283 @@ +;; This package is designed for sbcl. It implements the +;; ACL-style socket interface on top of sbcl. +;; +;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt +;; for Lispworks and net.lisp in the port library of CLOCC. + +(in-package #:acl-compat.socket) + +(defclass server-socket () + ((socket :initarg :socket :reader socket + :initform (error "No value supplied for socket")) + (element-type :type (member signed-byte unsigned-byte base-char) + :initarg :element-type + :reader element-type + :initform (error "No value supplied for element-type")) + (port :type fixnum + :initarg :port + :reader port + :initform (error "No value supplied for port")) + (stream-type :type (member :text :binary :bivalent) + :initarg :stream-type + :reader stream-type + :initform (error "No value supplied for stream-type")))) + +(defclass datagram-socket (server-socket) + ()) + + +(defmethod print-object ((socket server-socket) stream) + (print-unreadable-object (socket stream :type t :identity nil) + (format stream "listening on port ~d" (port socket)))) + +(defmethod print-object ((socket datagram-socket) stream) + (print-unreadable-object (socket stream :type t :identity nil) + (format stream "datagram socket listening on port ~d" (port socket)))) + +(defgeneric accept-connection (socket &key wait)) +(defmethod accept-connection ((server-socket server-socket) + &key (wait t)) + "Return a bidirectional stream connected to socket." + (if (sb-sys:wait-until-fd-usable (socket-file-descriptor (socket server-socket)) + :input (if (numberp wait) wait nil)) + (let* ((socket (socket-accept (socket server-socket))) + (stream (socket-make-stream socket + :input t :output t + ; :buffering :none + :element-type + (element-type server-socket) + :auto-close t))) + (if (eq (stream-type server-socket) :bivalent) + ;; HACK: remember socket, so we can do peer lookup + (make-bivalent-stream stream :plist `(:socket ,socket)) + stream)) + nil)) + +(defmethod receive-from ((socket datagram-socket) size &key buffer extract) + (multiple-value-bind (rbuf len address port) + (socket-receive (socket socket) buffer size) + (declare (ignore port)) + (let ((buf + (if (not extract) + rbuf + (subseq rbuf 0 len)))) ;; FIXME: am I right? + (when buffer + (replace buffer buf :end2 len)) + (values + (if buffer buffer buf) + len + address)))) + +(defmethod send-to ((socket datagram-socket) buffer size &key remote-host remote-port) + (let* ((rhost (typecase remote-host + (string (lookup-hostname remote-host)) + (otherwise remote-host))) + (s (socket socket)) + (stream (progn + (socket-connect s rhost remote-port) + (socket-make-stream s :input t :output t :buffering :none)))) + (write-sequence buffer stream) + size)) + + + +(defun make-socket (&key + (type :stream) + (remote-host "localhost") + local-port + remote-port + (connect :active) + (format :text) + (reuse-address t) + &allow-other-keys) + "Return a stream connected to remote-host if connect is :active, or +something listening on local-port that can be fed to accept-connection +if connect is :passive. + +This is an incomplete implementation of ACL's make-socket function! +It was written to provide the functionality necessary to port +AllegroServe. Refer to +http://franz.com/support/documentation/6.1/doc/pages/operators/socket/make-socket.htm +to read about the missing parts." + (check-type remote-host string) + (let ((element-type (ecase format + (:text 'base-char) + (:binary 'signed-byte) + (:bivalent 'unsigned-byte))) + (socket + (if (eq type :datagram) + (progn + (setf connect :passive-udp) + (make-instance 'inet-socket :type :datagram :protocol :udp)) + (make-instance 'inet-socket :type :stream :protocol :tcp)))) + (ecase connect + (:passive-udp + (setf (sockopt-reuse-address socket) reuse-address) + (if local-port + (socket-bind socket #(0 0 0 0) local-port)) + (make-instance 'datagram-socket + :port (nth-value 1 (socket-name socket)) + :socket socket + :element-type element-type + :stream-type format)) + (:passive + (setf (sockopt-reuse-address socket) reuse-address) + (if local-port + (socket-bind socket #(0 0 0 0) local-port)) + (socket-listen socket 10) ;Arbitrarily chosen backlog value + (make-instance 'server-socket + :port (nth-value 1 (socket-name socket)) + :socket socket + :element-type element-type + :stream-type format)) + (:active + (socket-connect socket (lookup-hostname remote-host) remote-port) + (let ((stream (socket-make-stream socket :input t :output t + :element-type element-type + ; :buffering :none + ))) + (if (eq :bivalent format) + ;; HACK: remember socket, so we can do peer lookup + (make-bivalent-stream stream :plist `(:socket ,socket)) + stream)))))) + +(defmethod close ((server server-socket) &key abort) + "Kill a passive (listening) socket. (Active sockets are actually +streams and handled by their close methods." + (declare (ignore abort)) + (socket-close (socket server))) + +#+ignore +(declaim (ftype (function ((unsigned-byte 32) &key (:values t)) + (or (values fixnum fixnum fixnum fixnum) + (values simple-string))) + ipaddr-to-dotted)) +(defun ipaddr-to-dotted (ipaddr &key values) + "Convert from 32-bit integer to dotted string." + (declare (type (unsigned-byte 32) ipaddr)) + (let ((a (logand #xff (ash ipaddr -24))) + (b (logand #xff (ash ipaddr -16))) + (c (logand #xff (ash ipaddr -8))) + (d (logand #xff ipaddr))) + (if values + (values a b c d) + (format nil "~d.~d.~d.~d" a b c d)))) + +(defun ipaddr-to-vector (ipaddr) + "Convert from 32-bit integer to a vector of octets." + (declare (type (unsigned-byte 32) ipaddr)) + (let ((a (logand #xff (ash ipaddr -24))) + (b (logand #xff (ash ipaddr -16))) + (c (logand #xff (ash ipaddr -8))) + (d (logand #xff ipaddr))) + (make-array 4 :initial-contents (list a b c d)))) + +(declaim (ftype (function (vector) + (values (unsigned-byte 32))) + vector-to-ipaddr)) +(defun vector-to-ipaddr (sensible-ipaddr) + "Convert from 4-integer vector to 32-bit integer." + (loop with result = 0 + for component across sensible-ipaddr + do (setf result (+ (ash result 8) component)) + finally (return result))) + +(defun string-tokens (string) + (labels ((get-token (str pos1 acc) + (let ((pos2 (position #\Space str :start pos1))) + (if (not pos2) + (nreverse acc) + (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2)) + acc)))))) + (get-token (concatenate 'string string " ") 0 nil))) + +(declaim (ftype (function (string &key (:errorp t)) + (or null (unsigned-byte 32))) + dotted-to-ipaddr)) +(defun dotted-to-ipaddr (dotted &key (errorp t)) + "Convert from dotted string to 32-bit integer." + (declare (string dotted)) + (if errorp + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll))) + (ignore-errors + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll)))))) + +(defun ipaddr-to-hostname (ipaddr &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported.")) + (host-ent-name (get-host-by-address (ipaddr-to-vector ipaddr)))) + +(defun lookup-hostname (host &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported.")) + (if (stringp host) + (host-ent-address (get-host-by-name host)) + (dotted-to-ipaddr (ipaddr-to-dotted host)))) + +(defun remote-host (socket-stream) + (let (socket) + (if (and (typep socket-stream 'chunked-stream) + (setf socket (getf (stream-plist socket-stream) :socket))) + (vector-to-ipaddr (socket-peername socket)) + (progn (warn "Could not get remote host for ~S" socket-stream) + 0)))) + +(defun remote-port (socket-stream) + (let (socket) + (if (and (typep socket-stream 'chunked-stream) + (setq socket (getf (stream-plist socket-stream) :socket))) + (nth-value 1 (socket-peername socket)) + (progn (warn "Could not get remote port for ~S" socket-stream) + 0)))) + +(defun local-host (thing) + (typecase thing + (chunked-stream (let ((socket (getf (stream-plist thing) :socket))) + (if socket (vector-to-ipaddr (socket-name socket)) + (progn (warn "Socket not in plist of ~S -- could not get local host" thing) + 0)))) + (server-socket (vector-to-ipaddr #(127 0 0 1))) + (t (progn (warn "Could not get local host for ~S" thing) + 0)))) + +(defun local-port (thing) + (typecase thing + (chunked-stream (let ((socket (getf (stream-plist thing) :socket))) + (if socket (nth-value 1 (socket-name socket)) + (progn (warn "Socket not in plist of ~S -- could not get local port" thing) + 0)))) + (server-socket (port thing)) + (t (progn (warn "Could not get local port for ~S" thing) + 0)))) + +;; Now, throw chunking in the mix + +(defclass chunked-stream (de.dataheaven.chunked-stream-mixin::chunked-stream-mixin + gray-stream::buffered-bivalent-stream) + ((plist :initarg :plist :accessor stream-plist))) + + +(defun make-bivalent-stream (lisp-stream &key plist) + (make-instance 'chunked-stream :lisp-stream lisp-stream :plist plist)) + + +(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p)) + (when oc-p + (when output-chunking + (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin::output-chunking-p stream) + output-chunking)) + (when output-chunking-eof + (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream)) + (when ic-p + (when input-chunking + (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream)) + (setf (de.dataheaven.chunked-stream-mixin::input-chunking-p stream) + input-chunking))) + + +(provide 'acl-socket) Added: branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-sys.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-sys.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,11 @@ +(in-package :acl-compat.system) + +(defun command-line-arguments () + sb-ext:*posix-argv*) + +(defun command-line-argument (n) + (nth n sb-ext:*posix-argv*)) + +(defun reap-os-subprocess (&key (wait nil)) + (declare (ignore wait)) + nil) Added: branches/trunk-reorg/thirdparty/acl-compat/scl/acl-excl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/scl/acl-excl.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,264 @@ +;;;; +;;;; ACL-COMPAT - EXCL +;;;; + +;;;; Implementation-specific parts of acl-compat.excl (see +;;;; acl-excl-common.lisp) + +(defpackage :acl-compat.excl + (:use #:common-lisp #:ext) + (:export + #:if* + #:*initial-terminal-io* + #:*cl-default-special-bindings* + #:filesys-size + #:filesys-write-date + #:stream-input-fn + #:match-regexp + #:compile-regexp + #:*current-case-mode* + #:intern* + #:filesys-type + #:errorset + #:atomically + #:fast + #:without-package-locks + #:string-to-octets + #:write-vector + + ;; TODO: find better place for bivalent stream classes + #:bivalent-input-stream + #:bivalent-output-stream + #:bivalent-stream + #:make-bivalent-input-stream + #:make-bivalent-output-stream + #:make-bivalent-stream + )) + +(in-package :acl-compat.excl) + +(defun stream-input-fn (stream) + stream) + +(defun filesys-type (file-or-directory-name) + (if (eq :directory (unix:unix-file-kind + (namestring file-or-directory-name))) + :directory + (if (probe-file file-or-directory-name) + :file + nil))) + +(defmacro atomically (&body forms) + `(mp:without-scheduling ,@forms)) + +(defun unix-signal (signal pid) + ;; fixxme: did I get the arglist right? only invocation I have seen + ;; is (excl::unix-signal 15 0) in net.aserve:start + (unix:unix-kill pid signal)) + +(defmacro without-package-locks (&body forms) + `(progn ,@forms)) + + +;;; Bivalent Gray streams + + +(defclass lisp-stream-mixin () + ;; For bivalent streams, lisp-stream must be a stream of type + ;; unsigned-byte + ((lisp-stream :initarg :lisp-stream + :accessor lisp-stream))) + +(defclass bivalent-input-stream (lisp-stream-mixin + fundamental-character-input-stream + fundamental-binary-input-stream)) + +(defclass bivalent-output-stream (lisp-stream-mixin + fundamental-character-output-stream + fundamental-binary-output-stream)) + +(defclass bivalent-stream (bivalent-input-stream bivalent-output-stream)) + + +(defun make-bivalent-input-stream (lisp-stream) + (declare (type system:lisp-stream lisp-stream)) + (make-instance 'bivalent-input-stream :lisp-stream lisp-stream)) + +(defun make-bivalent-output-stream (lisp-stream) + (declare (type system:lisp-stream lisp-stream)) + (make-instance 'bivalent-output-stream :lisp-stream lisp-stream)) + +(defun make-bivalent-stream (lisp-stream) + (declare (type system:lisp-stream lisp-stream)) + (make-instance 'bivalent-stream :lisp-stream lisp-stream)) + + +(defmethod open-stream-p ((stream lisp-stream-mixin)) + (common-lisp::open-stream-p (lisp-stream stream))) + +(defmethod close ((stream lisp-stream-mixin) &key abort) + (close (lisp-stream stream) :abort abort)) + +(defmethod input-stream-p ((stream lisp-stream-mixin)) + (input-stream-p (lisp-stream stream))) + +(defmethod output-stream-p ((stream lisp-stream-mixin)) + (output-stream-p (lisp-stream stream))) + +(defmethod stream-element-type ((stream bivalent-input-stream)) + '(or character (unsigned-byte 8))) + +(defmethod stream-read-char ((stream bivalent-input-stream)) + (code-char (read-byte (lisp-stream stream) nil :eof))) + +(defmethod stream-read-byte ((stream bivalent-input-stream)) + (read-byte (lisp-stream stream) nil :eof)) + +;; stream-unread-char + +(defmethod stream-read-char-no-hang ((stream bivalent-input-stream)) + (if (listen (lisp-stream stream)) + (code-char (read-byte (lisp-stream stream))) + nil)) + +;; stream-peek-char + +(defmethod stream-listen ((stream bivalent-input-stream)) + (listen (lisp-stream stream))) + +(defmethod stream-clear-input ((stream bivalent-input-stream)) + (clear-input (lisp-stream stream))) + +(defmethod stream-read-sequence ((stream bivalent-input-stream) + (seq vector) &optional start end) + (unless start (setf start 0)) + (unless end (setf end (length seq))) + (assert (<= end (length seq))) + (if (subtypep (array-element-type seq) 'character) + (loop for count upfrom start + for i from start below end + do (setf (aref seq i) (code-char (read-byte stream))) + finally (return count)) + (read-sequence seq (lisp-stream stream) + :start start :end end))) + +(defmethod stream-read-sequence ((stream bivalent-input-stream) + (seq cons) &optional (start 0) end) + (unless start (setf start 0)) + (unless end (setf end (length seq))) + (let ((seq (nthcdr start seq))) + (loop for count upfrom start + for head on seq + for i below (- end start) + while head + do (setf (car head) (read-byte stream)) + finally (return count)))) + +(defmethod stream-read-sequence ((stream bivalent-input-stream) + (seq null) &optional (start 0) end) + (declare (ignore end)) + start) + +(defmethod stream-element-type ((stream bivalent-output-stream)) + '(or character (unsigned-byte 8))) + +(defmethod stream-write-char ((stream bivalent-output-stream) character) + (write-byte (char-code character) (lisp-stream stream))) + +(defmethod stream-write-byte ((stream bivalent-output-stream) byte) + (write-byte byte (lisp-stream stream))) + +(defmethod stream-line-column ((stream bivalent-output-stream)) + nil) + +(defmethod stream-finish-output ((stream bivalent-output-stream)) + (finish-output (lisp-stream stream))) + +(defmethod stream-force-output ((stream bivalent-output-stream)) + (force-output (lisp-stream stream))) + +(defmethod stream-clear-output ((stream bivalent-output-stream)) + (clear-output (lisp-stream stream))) + +(defmethod stream-write-sequence ((stream bivalent-output-stream) + (seq vector) &optional (start 0) end) + (let ((length (length seq))) + (unless end (setf end length)) + (assert (<= end length))) + (unless start (setf start 0)) + (when (< end start) + (cerror "Continue with switched start and end ~s <-> ~s" + "Stream-write-sequence: start (~S) and end (~S) exchanged." + start end seq) + (rotatef start end)) + (cond + ((subtypep (array-element-type seq) '(unsigned-byte 8)) + (write-sequence seq (lisp-stream stream) :start start :end end)) + ((subtypep (array-element-type seq) 'character) + (loop for i from start below end + do (stream-write-char stream (aref seq i)))) + ((subtypep (array-element-type seq) 'integer) + (loop for i from start below end + do (stream-write-byte stream (aref seq i))))) + seq) + +(defmethod stream-write-sequence ((stream bivalent-output-stream) + (seq cons) &optional (start 0) end) + (let ((length (length seq))) + (unless end (setf end length)) + (assert (<= end length))) + (unless start (setf start 0)) + (when (< end start) + (cerror "Continue with switched start and end ~s <-> ~s" + "Stream-write-sequence: start (~S) and end (~S) exchanged." + start end seq) + (rotatef start end)) + (let ((seq (nthcdr start seq))) + (loop for element in seq + for i below (- end start) + while seq + do (etypecase element + (character (stream-write-char stream element)) + (integer (stream-write-byte stream element))))) + seq) + +(defmethod stream-write-sequence ((stream bivalent-output-stream) + (seq null) &optional (start 0) end) + (declare (ignore start end)) + seq) + +;;; End bivalent Gray streams + +(defun string-to-octets (string &key (null-terminate t) (start 0) + end mb-vector make-mb-vector? + (external-format :default)) + "This function returns a lisp-usb8-vector and the number of bytes copied." + (declare (ignore external-format)) + ;; The end parameter is different in ACL's lambda list, but this + ;; variant lets us give an argument :end nil explicitly, and the + ;; right thing will happen + (unless end (setf end (length string))) + (let* ((number-of-octets (if null-terminate (1+ (- end start)) + (- end start))) + (mb-vector (cond + ((and mb-vector (>= (length mb-vector) number-of-octets)) + mb-vector) + ((or (not mb-vector) make-mb-vector?) + (make-array (list number-of-octets) + :element-type '(unsigned-byte 8) + :initial-element 0)) + (t (error "Was given a vector of length ~A, ~ + but needed at least length ~A." + (length mb-vector) number-of-octets))))) + (declare (type (simple-array (unsigned-byte 8) (*)) mb-vector)) + (loop for from-index from start below end + for to-index upfrom 0 + do (progn + (setf (aref mb-vector to-index) + (char-code (aref string from-index))))) + (when null-terminate + (setf (aref mb-vector (1- number-of-octets)) 0)) + (values mb-vector number-of-octets))) + + +(provide 'acl-excl) Added: branches/trunk-reorg/thirdparty/acl-compat/scl/acl-mp.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/scl/acl-mp.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,155 @@ +;; This package is designed for cmucl. It implements ACL-style +;; multiprocessing on top of cmucl (basically, process run reasons and +;; some function renames). +;; +;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt +;; for Lispworks. + +(in-package :acl-compat-mp) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Import equivalent parts from the CMU MP package ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(shadowing-import '(mp:*current-process* + ;; mp::process-preset + mp::process-reset + mp:process-interrupt + mp::process-name + mp::process-wait-function + mp:process-run-reasons + mp:process-add-run-reason + mp:process-revoke-run-reason + mp:process-arrest-reasons + mp:process-add-arrest-reason + mp:process-revoke-arrest-reason + mp:process-whostate + ; mp:without-interrupts + mp:process-wait + mp:with-timeout + mp:without-scheduling + )) + +(export '(*current-process* + ;; process-preset + process-reset + process-interrupt + process-name + process-wait-function + process-whostate + process-wait + with-timeout + without-scheduling + process-run-reasons + process-add-run-reason + process-revoke-run-reason + process-arrest-reasons + process-add-arrest-reason + process-revoke-arrest-reason + )) + + +(defun process-allow-schedule () + (mp:process-yield)) + +(defvar *process-plists* (make-hash-table :test #'eq) + "maps processes to their plists. +See the functions process-plist, (setf process-plist).") + +(defun process-property-list (process) + (gethash process *process-plists*)) + +(defun (setf process-property-list) (new-value process) + (setf (gethash process *process-plists*) new-value)) + +#|| + +;;; rudi 2002-06-09: This is not needed as of cmucl 18d, thanks to Tim +;;; Moore who added run reasons to cmucl's multithreading. Left in +;;; for the time being just in case someone wants to get acl-compat +;;; running on older cmucl's. Can be deleted safely. + +(defvar *process-run-reasons* (make-hash-table :test #'eq) + "maps processes to their run-reasons. +See the functions process-run-reasons, (setf process-run-reasons), +process-add-run-reason, process-revoke-run-reason.") + +(defun process-run-reasons (process) + (gethash process *process-run-reasons*)) + +(defun (setf process-run-reasons) (new-value process) + (mp:without-scheduling + (prog1 + (setf (gethash process *process-run-reasons*) new-value) + (if new-value + (mp:enable-process process) + (mp:disable-process process))))) + +(defun process-revoke-run-reason (process object) + (without-scheduling + (setf (process-run-reasons process) + (remove object (process-run-reasons process)))) + (when (and (eq process mp:*current-process*)) + (mp:process-yield))) + +(defun process-add-run-reason (process object) + (setf (process-run-reasons process) + (pushnew object (process-run-reasons process)))) +||# + +(defun process-run-function (name-or-options preset-function + &rest preset-arguments) + (let ((process (ctypecase name-or-options + (string (make-process :name name-or-options)) + (list (apply #'make-process name-or-options))))) + (apply #'acl-mp::process-preset process preset-function preset-arguments) + process)) + +(defun process-preset (process preset-function &rest arguments) + (mp:process-preset process + #'(lambda () + (apply-with-bindings preset-function + arguments + (process-initial-bindings process))))) + +(defvar *process-initial-bindings* (make-hash-table :test #'eq)) + +(defun process-initial-bindings (process) + (gethash process *process-initial-bindings*)) + +(defun (setf process-initial-bindings) (bindings process) + (setf (gethash process *process-initial-bindings*) bindings)) + + +;;; ;;; +;;; Contributed by Tim Moore ;;; +;;; ;;; +(defun apply-with-bindings (function args bindings) + (if bindings + (progv + (mapcar #'car bindings) + (mapcar #'(lambda (binding) + (eval (cdr binding)))) + (apply function args)) + (apply function args))) + +(defun make-process (&key (name "Anonymous") reset-action run-reasons + arrest-reasons (priority 0) quantum resume-hook + suspend-hook initial-bindings run-immediately) + (declare (ignore priority quantum reset-action resume-hook suspend-hook + run-immediately)) + (mp:make-process nil :name name + :run-reasons run-reasons + :arrest-reasons arrest-reasons + :initial-bindings initial-bindings)) + +(defun process-kill (process) + (mp:destroy-process process)) + + +(defun make-process-lock (&key name) + (mp:make-lock name)) + +(defmacro with-process-lock ((lock &key norecursive) &body forms) + (declare (ignore norecursive)) + `(mp:with-lock-held (,lock) ,@forms)) Added: branches/trunk-reorg/thirdparty/acl-compat/scl/acl-socket.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/scl/acl-socket.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,196 @@ +;; This package is designed for scl. It implements the +;; ACL-style socket interface on top of scl. +;; +;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt +;; for Lispworks and net.lisp in the port library of CLOCC. +;; +;; This was modified for SCL by Kevin Rosenberg + +(defpackage acl-socket + (:use "MP" "COMMON-LISP") + #+cl-ssl (:import-from :ssl "MAKE-SSL-CLIENT-STREAM" "MAKE-SSL-SERVER-STREAM") + (:export #:socket #:make-socket #:accept-connection + #:ipaddr-to-dotted #:dotted-to-ipaddr #:ipaddr-to-hostname #:lookup-hostname + #:remote-host #:remote-port #:local-host #:local-port #:socket-control + #+cl-ssl #:make-ssl-client-stream #+cl-ssl #:make-ssl-server-stream) + (:nicknames socket)) + +(in-package socket) + +(defclass socket () + ((fd :type fixnum + :initarg :fd + :reader fd))) + +(defmethod print-object ((socket socket) stream) + (print-unreadable-object (socket stream :type t :identity t) + (format stream "@~d" (fd socket)))) + +(defclass server-socket (socket) + ((element-type :type (member signed-byte unsigned-byte base-char) + :initarg :element-type + :reader element-type + :initform (error "No value supplied for element-type")) + (port :type fixnum + :initarg :port + :reader port + :initform (error "No value supplied for port")) + (stream-type :type (member :text :binary :bivalent) + :initarg :stream-type + :reader stream-type + :initform (error "No value supplied for stream-type")))) + +#+cl-ssl +(defmethod make-ssl-server-stream ((lisp-stream system:lisp-stream) + &rest options) + (apply #'make-ssl-server-stream (system:fd-stream-fd lisp-stream) options)) + +(defmethod print-object ((socket server-socket) stream) + (print-unreadable-object (socket stream :type t :identity nil) + (format stream "@~d on port ~d" (fd socket) (port socket)))) + +(defmethod accept-connection ((server-socket server-socket) + &key (wait t)) + "Return a bidirectional stream connected to socket, or nil if no +client wanted to initiate a connection and wait is nil." + ;; fixxme: perhaps check whether we run multiprocessing and use + ;; sys:wait-until-fd-usable instead of + ;; mp:process-wait-until-fd-usable here? + + ;; api pipe fitting: wait t ==> timeout nil + (when (mp:process-wait-until-fd-usable (fd server-socket) :input + (if wait nil 0)) + (let ((stream (sys:make-fd-stream + (ext:accept-tcp-connection (fd server-socket)) + :input t :output t + :element-type (element-type server-socket) + :auto-close t))) + (if (eq (stream-type server-socket) :bivalent) + (excl:make-bivalent-stream stream) + stream)))) + +(defun make-socket (&key (remote-host "localhost") + local-port + remote-port + (connect :active) + (format :text) + &allow-other-keys) + "Return a stream connected to remote-host if connect is :active, or +something listening on local-port that can be fed to accept-connection +if connect is :passive. + +This is an incomplete implementation of ACL's make-socket function! +It was written to provide the functionality necessary to port +AllegroServe. Refer to +http://franz.com/support/documentation/6.1/doc/pages/operators/socket/make-socket.htm +to read about the missing parts." + (check-type remote-host string) + (let ((element-type (ecase format + (:text 'base-char) + (:binary 'signed-byte) + (:bivalent 'unsigned-byte)))) + (ecase connect + (:passive + (make-instance 'server-socket + :port local-port + :fd (ext:create-inet-listener local-port) + :element-type element-type + :stream-type format)) + (:active + (let ((stream (sys:make-fd-stream + (ext:connect-to-inet-socket remote-host remote-port) + :input t :output t :element-type element-type))) + (if (eq :bivalent format) + (excl:make-bivalent-stream stream) + stream)))))) + +(defmethod close ((server server-socket) &key abort) + "Kill a passive (listening) socket. (Active sockets are actually +streams and handled by their close methods." + (declare (ignore abort)) + (unix:unix-close (fd server))) + +(declaim (ftype (function ((unsigned-byte 32) &key (:values t)) + (values simple-string)) + ipaddr-to-dotted)) +(defun ipaddr-to-dotted (ipaddr &key values) + (declare (type (unsigned-byte 32) ipaddr)) + (let ((a (logand #xff (ash ipaddr -24))) + (b (logand #xff (ash ipaddr -16))) + (c (logand #xff (ash ipaddr -8))) + (d (logand #xff ipaddr))) + (if values + (values a b c d) + (format nil "~d.~d.~d.~d" a b c d)))) + +(defun string-tokens (string) + (labels ((get-token (str pos1 acc) + (let ((pos2 (position #\Space str :start pos1))) + (if (not pos2) + (nreverse acc) + (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2)) + acc)))))) + (get-token (concatenate 'string string " ") 0 nil))) + +(declaim (ftype (function (string &key (:errorp t)) + (values (unsigned-byte 32))) + dotted-to-ipaddr)) +(defun dotted-to-ipaddr (dotted &key (errorp t)) + (declare (string dotted)) + (if errorp + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll))) + (ignore-errors + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll)))))) + +(defun ipaddr-to-hostname (ipaddr &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported.")) + (ext:host-entry-name (ext:lookup-host-entry ipaddr))) + +(defun lookup-hostname (host &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported.")) + (if (stringp host) + (car (ext:host-entry-addr-list (ext:lookup-host-entry host))) + (dotted-to-ipaddr (ipaddr-to-dotted host)))) + +(defgeneric get-fd (stream)) + +(defmethod get-fd ((stream excl::lisp-stream-mixin)) + (system:fd-stream-fd (excl::lisp-stream stream))) + +(defmethod get-fd ((stream system:lisp-stream)) + (system:fd-stream-fd stream)) + +(defun remote-host (socket-stream) + (ext:get-peer-host-and-port (get-fd socket-stream))) + +(defun remote-port (socket-stream) + (multiple-value-bind (host port) + (ext:get-peer-host-and-port (get-fd socket-stream)) + (declare (ignore host)) + port)) + +(defun local-host (socket-stream) + (ext:get-socket-host-and-port (get-fd socket-stream))) + +(defun local-port (socket-stream) + (if (typep socket-stream 'socket::server-socket) + (port socket-stream) + (multiple-value-bind (host port) + (ext:get-socket-host-and-port (get-fd socket-stream)) + (declare (ignore host)) + port))) + +(defun socket-control (stream &key output-chunking output-chunking-eof input-chunking) + (declare (ignore stream)) + (warn "SOCKET-CONTROL function not implemented.") + (when (or output-chunking output-chunking-eof input-chunking) + (error "Chunking is not yet supported in scl. Restart the server with chunking off."))) + + +(provide 'acl-socket) Added: branches/trunk-reorg/thirdparty/acl-compat/scl/acl-sys.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/scl/acl-sys.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,18 @@ +(in-package :sys) + +(ignore-errors +(export 'command-line-arguments) +(export 'command-line-argument) +(export 'reap-os-subprocess) + +(defun command-line-arguments () + ext:*command-line-strings*) + +(defun command-line-argument (n) + (nth n ext:*command-line-strings*)) + +(defun reap-os-subprocess (&key (wait nil)) + (declare (ignore wait)) + nil) + +) Added: branches/trunk-reorg/thirdparty/acl-compat/test-acl-socket.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/acl-compat/test-acl-socket.lisp Thu Feb 7 03:21:48 2008 @@ -0,0 +1,61 @@ +;;; Unit tests for the ACL-SOCKET compatibility package. + +(in-package cl-user) + +(require :acl-socket) + +(use-package '(acl-socket)) + +(defun test1 () + (let ((stream (make-socket :connect :active :remote-host "127.0.0.1" :remote-port 2500))) + (when stream + (read-line stream) + (format stream "helo foo") + (write-char #\Return stream) + (write-char #\Linefeed stream) + (finish-output stream) + (read-line stream) + (close stream)))) + +(defun test2 () + (let ((stream (make-socket :connect :active :remote-host "127.0.0.1" :remote-port 2500))) + (when stream + (socket-control stream :output-chunking t) + (read-line stream) + (format stream "helo foo") + (write-char #\Return stream) + (write-char #\Linefeed stream) + (finish-output stream) + (read-line stream) + (close stream)))) + +(defun test3 () + (let ((stream (make-socket :connect :active :remote-host "127.0.0.1" :remote-port 2500))) + (when stream + (socket-control stream :input-chunking t) + (prog1 + (read-line stream) + (close stream))))) + +(defun test4 () + (let ((stream (or (make-socket :connect :active :remote-host "127.0.0.1" :remote-port 2500) + (error "Failed to connect.")))) + (socket-control stream :input-chunking t) + (format t "File number 1: ") + #1=(handler-case + (loop + for char = (read-char stream nil stream) + until (eq char stream) + do (write-char char)) + (excl::socket-chunking-end-of-file (e) (socket-control stream :input-chunking t))) + (format t "~%File number 2: ") + #1# + (terpri) + (values))) + + + + + + +

1 0

[bknr-cvs] r2449 - in branches/trunk-reorg/thirdparty: hunchentoot-0.14.7 hunchentoot-0.15.0 hunchentoot-0.15.0/doc hunchentoot-0.15.0/test
by hhubner＠common-lisp.net 07 Feb '08

07 Feb '08

Author: hhubner Date: Thu Feb 7 03:16:29 2008 New Revision: 2449 Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/CHANGELOG (contents, props changed) branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/CHANGELOG_TBNL branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/README (contents, props changed) branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/conditions.lisp (contents, props changed) branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/cookie.lisp branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/doc/ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/doc/LICENSE.txt (contents, props changed) branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/doc/hunchentoot.gif (contents, props changed) branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/doc/index.html (contents, props changed) branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/easy-handlers.lisp (contents, props changed) branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/headers.lisp (contents, props changed) branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/hunchentoot-test.asd (contents, props changed) branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/hunchentoot.asd (contents, props changed) branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/log.lisp branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/mime-types.lisp branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/misc.lisp (contents, props changed) branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/packages.lisp (contents, props changed) branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-acl.lisp branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-clisp.lisp branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-cmu.lisp branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-lw.lisp (contents, props changed) branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-mcl.lisp branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-sbcl.lisp branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/reply.lisp branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/request.lisp branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/server.lisp (contents, props changed) branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/session.lisp branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/specials.lisp (contents, props changed) branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/UTF-8-demo.html branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/favicon.ico (contents, props changed) branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/fz.jpg (contents, props changed) branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/packages.lisp (contents, props changed) branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/test.lisp branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-acl.lisp branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-clisp.lisp branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-cmu.lisp branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-lw.lisp (contents, props changed) branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-mcl.lisp branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-sbcl.lisp branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/util.lisp (contents, props changed) Removed: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/ Log: update hunchentoot Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/CHANGELOG ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/CHANGELOG Thu Feb 7 03:16:29 2008 @@ -0,0 +1,281 @@ +Version 0.15.0 +2007-12-29 +Added support for CLISP (thanks to Anton Vodonosov) + +Version 0.14.7 +2007-11-15 +Replace ENOUGH-NAMESTRING with ENOUGH-URL (patch by Kilian Sprotte and Hans H�bner) + +Version 0.14.6 +2007-11-08 +Fix compilation order (thanks to Tiarnan O'Corrain and Chris Dean) + +Version 0.14.5 +2007-10-21 +Robustified MAKE-SOCKET-STREAM against potential leak (thanks to Alain Picard) +Replaced #-FOO #-FOO constructs for OpenMCL (patch by Michael Weber) +Updated tutorial links + +Version 0.14.4 +2007-10-20 +Made log stream shared on OpenMCL (thanks to Gary Byers) + +Version 0.14.3 +2007-10-07 +Enabled GET-GID-FROM-NAME for newer versions of SBCL (patch by Cyrus Harmon) + +Version 0.14.2 +2007-09-26 +Better handling of PORT parameter in REDIRECT (thanks to Vladimir Sedach) + +Version 0.14.1 +2007-09-24 +Fixed bug where you couldn't set "Server" header (caught by Ralf Mattes) +Documentation clarification for HEADER-OUR function + +Version 0.14.0 +2007-09-18 +Added support for "HttpOnly" cookie attribute + +Version 0.13.0 +2007-09-14 +Added *METHODS-FOR-POST-PARAMETERS* (suggested by Jonathon McKitrick) + +Version 0.12.1 +2007-09-13 +Better support for WITH-TIMEOUT on SBCL/Win32 (thanks to Anton Vodonosov) + +Version 0.12.0 +2007-09-07 +Now uses bound for flexi stream returned by RAW-POST-DATA +Needs FLEXI-STREAMS 0.12.0 or higher + +Version 0.11.2 +2007-09-05 +Fixed typo in docs +Added declaration in server.lisp to appease SBCL + +Version 0.11.1 +2007-05-25 +Fixes for OpenMCL (thanks to Lennart Staflin and Tiarnan O'Corrain) + +Version 0.11.0 +2007-05-25 +Added server names and coupled them with easy handlers (suggested by Mac Chan) +Exported SESSION-COOKIE-VALUE instead of SESSION-STRING (suggested by Slava Akhmechet) +Documentation fixes (thanks to Victor Kryukov and Igor Plekhov) + +Version 0.10.0 +2007-05-12 +Made MAYBE-INVOKE-DEBUGGER a generic function and exported it (suggested by Vladimir Sedach) + +Version 0.9.3 +2007-05-08 +Fixed CREATE-FOLDER-DISPATCHER-AND-HANDLER in the presence of URL-encoded URLs (bug caught by Nicolas Lamirault) + +Version 0.9.2 +2007-05-01 +Made DEF-HTTP-RETURN-CODE more flexible (suggested by Jong-won Choi) + +Version 0.9.1 +2007-04-29 +Added PORT parameter to REDIRECT (suggested by Cyrus Harmon) +Exported REMOVE-SESSION (suggested by Vamsee Kanakala) + +Version 0.9.0 +2007-04-19 +Added socket timeouts for AllegroCL +Catch IO timeout conditions for AllegroCL, SBCL and CMUCL (suggested by Red Daly and others) +Added per-server dispatch tables (suggested by Robert Synnott and Andrei Stebakov) + +Version 0.8.6 +2007-04-18 +USE the CL package explicitly when defining HUNCHENTOOT-MP (bug report by Joel Boehland) + +Version 0.8.5 +2007-04-10 +Correct behaviour for "100 Continue" responses + +Version 0.8.4 +2007-04-09 +Cleanup + +Version 0.8.3 +2007-04-07 +Don't use chunked encoding for empty (NIL) bodies + +Version 0.8.2 +2007-04-05 +Really exported REASON-PHRASE this time (and also *CURRENT-PROCESS*) + +Version 0.8.1 +2007-04-04 +Added HUNCHENTOOT-MP package (suggested by Cyrus Harmon) +Only invoke MARK-AND-SWEEP for 32-bit versions of LW (thanks to Chris Dean) +Exported REASON-PHRASE + +Version 0.8.0 +2007-03-31 +Added *APPROVED-RETURN-CODES*, *HEADER-STREAM*, and +HTTP-FAILED-DEPENDENCY+ +Exported MIME-TYPE and SSL-P +Some minor changes + +Version 0.7.3 +2007-03-28 +Added +HTTP-MULTI-STATUS+ + +Version 0.7.2 +2007-03-09 +Fix test suite to properly handle non-base characters in LW (bug caught by Jong-won Choi) + +Version 0.7.1 +2007-03-09 +Fixed last change (thanks to Marko Kocic) + +Version 0.7.0 +2007-03-09 +Development port (no threads) to SBCL/Win32 (patch by Marko Kocic) +Support for compilation without SSL + +Version 0.6.2 +2007-02-22 +Don't use NSTRING-UPCASE for outgoing headers (bug caught by Saurabh Nanda) +Changed ProxyPass example in docs from /lisp to /hunchentoot + +Version 0.6.1 +2007-01-24 +Reset to "faithful" external format on each iteration (bug caught by Viljo Marrandi and Ury Marshak) + +Version 0.6.0 +2007-01-23 +Accept chunked transfer encoding for mod_lisp request bodies (thanks to Hugh Winkler's mod_lisp additions) +Robustify against erroneous form-data submissions (caught by Ury Marshak) + +Version 0.5.1 +2007-01-18 +Even more flexible behaviour of RAW-POST-DATA + +Version 0.5.0 +2007-01-17 +More flexible behaviour of RAW-POST-DATA +Robustified PARSE-CONTENT-TYPE + +Version 0.4.14 +2007-01-17 +More meaningful results for RAW-POST-DATA + +Version 0.4.13 +2007-01-14 +Added favicon.ico to example website (thanks to Yoni Rabkin Katzenell, Toby, and Uwe von Loh) + +Version 0.4.12 +2006-12-27 +Added Hunchentoot logo by Uwe von Loh + +Version 0.4.11 +2006-12-01 +Exported symbols related to session GC (suggested by Nico de Jager) + +Version 0.4.10 +2006-11-19 +Added *HANDLE-HTTP-ERRORS-P* (thanks to Marijn Haverbeke) +Remove duplicate headers when reading from mod_lisp + +Version 0.4.9 +2006-11-12 +Fixed HEADER-OUT (thanks to Robert J. Macomber) + +Version 0.4.8 +2006-11-06 +Fixed bug in START-OUTPUT which confused mod_lisp + +Version 0.4.7 +2006-11-06 +Changed behaviour of REAL-REMOTE-ADDR (as suggested by Robert J. Macomber) +Fixed COOKIE-OUT (thanks to Robert J. Macomber) + +Version 0.4.6 +2006-11-05 +Don't bind *DISPATCH-TABLE* too early (thanks to Marijn Haverbeke) + +Version 0.4.5 +2006-10-25 +Fixed bug in AUTHORIZATION function (reported by Michael J. Forster) + +Version 0.4.4 +2006-10-12 +Correct SSL check in REDIRECT function +LOG-MESSAGE now checks for (BOUNDP '*SERVER*) + +Version 0.4.3 +2006-10-11 +OpenMCL fixes (by Ralf Stoye) + +Version 0.4.2 +2006-10-10 +No timeouts for mod_lisp servers (as in Hunchentoot 0.3.x) + +Version 0.4.1 +2006-10-10 +Fixed a typo in easy-handlers.lisp (caught by Travis Cross) + +Version 0.4.0 +2006-10-10 +Ported to CMUCL, SBCL, OpenMCL, and AllegroCL +Merged with TBNL +Tons of small changes, too many to list them individually + +Version 0.3.2 +2006-09-14 +Uses TBNL's WITH-DEBUGGER now + +Version 0.3.1 +2006-09-14 +Added *CATCH-ERRORS-P* (from TBNL) + +Version 0.3.0 +2006-09-05 +Accept HTTP requests with chunked transfer encoding +Use Chunga for chunking + +Version 0.2.2 +2006-08-31 +Skip START-OUTPUT advice completely if working for TBNL + +Version 0.2.1 +2006-08-28 +Added write timeouts for LW 5.0 +Updated LW links in documentation + +Version 0.2.0 +2006-08-28 +Serves as infrastructure for TBNL now (to replace KMRCL) +For HTTP/1.1 only send 'Keep-Alive' headers if explicitly requested + +Version 0.1.5 +2006-08-23 +Connection headers are separated by commas, not semicolons + +Version 0.1.4 +2006-08-22 +Refactored streams.lisp to appease LW compiler (thanks to Martin Simmons) +Changed handling of version string +Changed package handling in system definition (thanks to Christophe Rhodes) + +Version 0.1.3 +2006-02-08 +Removed KMRCL workaround + +Version 0.1.2 +2006-01-03 +Mention TBNL version number in server name header + +Version 0.1.1 +2005-12-31 +Fixed package stuff and HYPERDOC support + +Version 0.1.0 +2005-12-31 +Initial public release + +[For earlier changes see the file "CHANGELOG_TBNL" that is included with the release.] Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/CHANGELOG_TBNL ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/CHANGELOG_TBNL Thu Feb 7 03:16:29 2008 @@ -0,0 +1,340 @@ +Version 0.11.3 +2006-09-30 +Added *FILE-UPLOAD-HOOK* (suggested by Erik Enge) +Fixed DEFINE-EASY-HANDLER for cases where URI is NIL + +Version 0.11.2 +2006-09-20 +DEFINE-EASY-HANDLER: fixed and clarified redefinition +DEFINE-EASY-HANDLER: allow for functions designators as "URIs" +DEFINE-EASY-HANDLER: take file uploads into account +Made logging a little bit more robust +Added mime type for XSL-FO (.fo) + +Version 0.11.1 +2006-09-14 +Cleaner implementation of *CATCH-ERRORS-P* + +Version 0.11.0 +2006-09-14 +Added *CATCH-ERRORS-P* + +Version 0.10.3 +2006-09-05 +Appease SBCL (thanks to Juho Snellman) + +Version 0.10.2 +2006-09-05 +Better reporting of IP addresses and ports if not behind mod_lisp +Improved logging +Fixed REAL-REMOTE-ADDR +Cookies always use UTF-8 encoding (which is opaque to the client anyway) +Read request bodies without 'Content-Length' header (for Hunchentoot) +Removed accented character from test.lisp to appease SBCL (reported by Xristos Kalkanis) + +Version 0.10.1 +2006-08-31 +Only LispWorks: Set read timeout to NIL if connected to mod_lisp + +Version 0.10.0 +2006-08-28 +Based LispWorks version of TBNL on Hunchentoot infrastructure +Added "easy" handlers +Exported GET-BACKTRACE (suggested by Erik Enge) + +Version 0.9.11 +2006-08-16 +Added note about SBCL problems + +Version 0.9.10 +2006-05-24 +Prepare for LW 5.0 release + +Version 0.9.9 +2006-05-12 +Workaround for something like "application/x-www-form-urlencoded;charset=UTF-8" (caught by John Bates) + +Version 0.9.8 +2006-04-25 +For mod_lisp, Lisp-Content-Length header must be sent after Content-Length header + +Version 0.9.7 +2006-02-06 +More robust computation of content length + +Version 0.9.6 +2006-01-22 +Added the missing piece (argh!) + +Version 0.9.5 +2006-01-22 +Made creation of REQUEST object safer (thanks to Robert J. Macomber) +Replaced some erroneous DECLAIMs with DECLAREs (thanks to SBCL's style warnings) +Slight documentation enhancements + +Version 0.9.4 +2006-01-03 +Handle "Expect: 100-continue" for non-Apache front-ends +Re-introduced IGNORE-ERRORS in GET-REQUEST-DATA + +Version 0.9.3 +2006-01-01 +Fixed bug in READ-HTTP-REQUEST + +Version 0.9.2 +2005-12-31 +Protocol of reply is HTTP/1.1 now +Made HTTP/0.9 default protocol of request if none was provided +Some preparations for Hunchentoot +Various minor changes +Small fixes in docs + +Version 0.9.1 +2005-12-25 +Added missing file mime-types.lisp (thanks to Hilverd Reker) + +Version 0.9.0 +2005-12-24 +Experimental support for writing directly to the front-end (see SEND-HEADERS) +Added HANDLE-STATIC-FILE +Changed CREATE-STATIC-FILE-DISPATCHER-AND-HANDLER to use new facilities +Added CREATE-FOLDER-DISPATCHER-AND-HANDLER +Added link to Travis Cross' message w.r.t. SBCL + +Version 0.8.9 +2005-12-16 +Also use :TBNL-BIVALENT-STREAMS if :SB-UNICODE is present + +Version 0.8.8 +2005-12-08 +Made RAW-POST-DATA more useful +Updated docs w.r.t. Araneida (thanks to Alan Shields) + +Version 0.8.7 +2005-11-29 +Made "Content-Length" header SETFable + +Version 0.8.6 +2005-11-18 +Restored original stream-based code for multipart/form-data parsing (got lost somehow) +Wrapped REMOTE-ADDR with IGNORE-ERRORS (just in case) + +Version 0.8.5 +2005-11-14 +Added generic function DISPATCH-REQUEST (thanks to Jeff Caldwell) + +Version 0.8.4 +2005-10-21 +Provide REMOTE-ADDR if connected directly (for LispWorks and AllegroCL) +Show remote user and address (if available) in non-Apache logs +Mention Debian package in docs + +Version 0.8.3 +2005-10-10 +Alert LW users that a patch for OCTETS-TO-STRINGS is available (thanks to LispWorks support) + +Version 0.8.2 +2005-10-06 +Make STRING-TO-OCTETS and OCTETS-TO-STRING safer for LW + +Version 0.8.1 +2005-09-29 +Bugfix in CMUCL version of STRING-TO-OCTETS + +Version 0.8.0 +2005-09-24 +Added the ability to cope with different external formats (incorporating suggestions from Will Glozer and Ivan Shvedunov) +Raw post data is now always saved (so *SAVE-RAW-POST-DATA-P* is gone) + +Version 0.7.0 +2005-09-17 +Added the ability to store arbitrary data within REQUEST objects (suggested by Zach Beane) +Fixed handling of *HTTP-ERROR-HANDLER* +Note: *TBNL-VERSION* was wrong in 0.6.0 and 0.6.1 + +Version 0.6.1 +2005-09-10 +Robustified socket handling code + +Version 0.6.0 +2005-09-08 +Added TBNL-CONTRIB package +Added contrib directory with first entry (from Alceste Scalas) +Updated link to Bill Clementson's blog +Don't redefine what's already there (for LispWorks) + +Version 0.5.5 +2005-04-18 +Make RFC 2388 code an external dependency (thanks to Janis Dzerins) + +Version 0.5.4 +2005-04-03 +Fixed dumb typo (caught by Bob Hutchison) + +Version 0.5.3 +2005-04-03 +Re-introduced automatic front-end selection (originally by Bob Hutchison) + +Version 0.5.2 +2005-03-26 +Fixed bug in modlisp.html where *CLOSE-TBNL-STREAM* could be NIL although it should be T +Set correct content type for 304 replies + +Version 0.5.1 +2005-03-17 +Changed default cookie path in START-SESSION (suggested by Stefan Scholl) +Small bugfixes +More headers from the Araneida front-end +Added *SHOW-ACCESS-LOG-MESSAGES* +Changed "back-end" to "front-end" :) + +Version 0.5.0 +2005-03-17 +Initial support for "stand-alone" version (no front-end) (supplied by Bob Hutchison) +New logging API +Fixes in START-TBNL/STOP-TBNL +Documentation enhancements + +Version 0.4.1 +2005-03-15 +Fixed some typos, removed unused code + +Version 0.4.0 +2005-03-14 +Initial Araneida support (supplied by Bob Hutchison) + +Version 0.3.13 +2005-03-12 +Small bugfix in RFC-1123-DATE (thanks to Bob Hutchison and Stefan Scholl) + +Version 0.3.12 +2005-03-01 +Added *HTTP-ERROR-HANDLER* (suggested and coded by Stefan Scholl) +Exported and documented *SESSION-MAX-TIME* + +Version 0.3.11 +2005-02-21 +Added ability to access raw post data (suggested and coded by Zach Beane) + +Version 0.3.10 +2005-01-24 +Make bivalent streams work with LispWorks 4.4 +UTF-8 demo for LispWorks (thanks to Bob Hutchison) + +Version 0.3.9 +2004-12-31 +Re-compute content length after applying MAYBE-REWRITE-URLS-FOR-SESSION (caught by Stefan Scholl) + +Version 0.3.8 +2004-12-27 +Don't send body for HEAD requests (needs current mod_lisp version) + +Version 0.3.7 +2004-12-22 +Change #\Del to #\Rubout in QUOTE-STRING (AllegroCL complains, #\Del isn't even semi-standard) + +Version 0.3.6 +2004-12-02 +Make REQUIRE-AUTHORIZATION compliant to RFC 2616 (thanks to Stefan Scholl) + +Version 0.3.5 +2004-12-01 +Several small doc fixes (thanks to Stefan Scholl) +Catch requests like "GET http://server/foo.html HTTP/1.0" (suggested by Stefan Scholl) + +Version 0.3.4 +2004-11-29 +Added backtrace code for OpenMCL (provided by Tiarn�n � Corr�in) + +Version 0.3.3 +2004-11-22 +Cleaner handling of macro variables + +Version 0.3.2 +2004-11-11 +Updated docs for mod_lisp2 + +Version 0.3.1 +2004-11-09 +Slight changes to support Chris Hanson's mod_lisp2 +Changed GET-BACKTRACE for newer SBCL versions (thanks to Nikodemus Siivola) + +Version 0.3.0 +2004-11-09 +Initial support for multipart/form-data (thanks to Michael Weber and Janis Dzerins) +Fixed bug in CREATE-STATIC-FILE-DISPATCHER-AND-HANDLER (caught by Bill Clementson) + +Version 0.2.12 +2004-10-15 +Exported and documented DO-SESSIONS + +Version 0.2.11 +2004-09-02 +FORM-URL-ENCODED-LIST-TO-ALIST now decodes names and values + +Version 0.2.10 +2004-08-28 +Allow non-strings to be cookie values (bug caught by Zach Beane) + +Version 0.2.9 +2004-08-11 +Consistent usage of RFC-1123-DATE (provided by Stefan Scholl) +Added all missing http headers from RFC 2616 (provided by Stefan Scholl) +Added support for mod_lisp version strings (see <http://common-lisp.net/pipermail/mod-lisp-devel/2004-August/000019.html>) +Don't always add session IDs when redirecting + +Version 0.2.8 +2004-07-24 +Fixed typo in html.lisp and improved docs (both caught by Stefan Scholl) + +Version 0.2.7 +2004-07-24 +Add missing exports and docs + +Version 0.2.6 +2004-07-24 +Make CREATE-STATIC-FILE-DISPATCHER-AND-HANDLER thread-safe (caught by Jeff Caldwell) +Added support for 'If-Modified-Since' request headers (provided by Stefan Scholl) + +Version 0.2.5 +2004-07-21 +Added CREATE-STATIC-FILE-DISPATCHER-AND-HANDLER (provided by Stefan Scholl) +Improved test suite + +Version 0.2.4 +2004-07-19 +New variable *CONTENT-TYPES-FOR-URL-REWRITE* (suggested by Stefan Scholl) +Updated index.html regarding new version of mod_lisp + +Version 0.2.3 +2004-06-12 +Bugfix for FORM-URL-ENCODED-LIST-TO-ALIST (bug caught by Jong-won Choi) + +Version 0.2.2 +2004-06-10 +Bugfix for SESSION-GC and RESET-SESSIONS (bug introduced in 0.2.0) + +Version 0.2.1 +2004-06-10 +Only create backtrace if needed (speeds up AllegroCL considerably) + +Version 0.2.0 +2004-06-07 +Added SESSION-STRING and *SESSION-REMOVAL-HOOK* +Added GET-BACKTRACE for AllegroCL + +Version 0.1.2 +2004-05-12 +Removed some more typos in docs (thanks to Karl A. Krueger) +Changed BASE64 to CL-BASE64 in .asd file (thanks to Frank Sonnemans and Nicolas Lamirault) + +Version 0.1.1 +2004-05-08 +Removed some old files from Jeff's port +Fixed a couple of typos in docs + +Version 0.1.0 +2004-05-07 +First public release +Original code by Edi Weitz +Initial doc strings, port to KMRCL, logging code and various other improvements by Jeff Caldwell Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/README ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/README Thu Feb 7 03:16:29 2008 @@ -0,0 +1,2 @@ +Complete documentation for Hunchentoot including details about how to +install it can be found in the 'doc' directory. Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/conditions.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/conditions.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,60 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/conditions.lisp,v 1.1 2007/11/08 20:07:58 edi Exp $ + +;;; Copyright (c) 2004-2007, 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) + +(defvar *catch-errors-p* t + "Whether Hunchentoot should catch and log errors \(or rather +invoke the debugger).") + +(defgeneric maybe-invoke-debugger (condition) + (:documentation "This generic function is called whenever a +condition CONDITION is signaled in Hunchentoot. You might want to +specialize it on specific condition classes for debugging purposes.") + (:method (condition) + "The default method invokes the debugger with CONDITION if +*CATCH-ERRORS-P* is NIL." + (unless *catch-errors-p* + (invoke-debugger condition)))) + +(defmacro with-debugger (&body body) + "Executes BODY and invokes the debugger if an error is signaled and +*CATCH-ERRORS-P* is NIL." + `(handler-bind ((error #'maybe-invoke-debugger)) + ,@body)) + +(defmacro ignore-errors (&body body) + "Like CL:IGNORE-ERRORS, but observes *CATCH-ERRORS-P*." + `(cl:ignore-errors (with-debugger ,@body))) + +(defmacro handler-case (expression &rest clauses) + "Like CL:HANDLER-CASE, but observes *CATCH-ERRORS-P*." + `(cl:handler-case (with-debugger ,expression) + ,@clauses)) + Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/cookie.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/cookie.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,121 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/cookie.lisp,v 1.7 2007/09/18 14:23:23 edi Exp $ + +;;; Copyright (c) 2004-2007, 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 cookie () + ((name :initarg :name + :reader cookie-name + :type string + :documentation "The name of the cookie - a string.") + (value :initarg :value + :accessor cookie-value + :initform "" + :documentation "The value of the cookie. Will be URL-encoded +when sent to the browser.") + (expires :initarg :expires + :initform nil + :accessor cookie-expires + :documentation "The time \(a universal time) when the +cookie expires \(or NIL).") + (path :initarg :path + :initform nil + :accessor cookie-path + :documentation "The path this cookie is valid for \(or NIL).") + (domain :initarg :domain + :initform nil + :accessor cookie-domain + :documentation "The domain this cookie is valid for \(or NIL).") + (secure :initarg :secure + :initform nil + :accessor cookie-secure + :documentation "A generalized boolean denoting whether this +cookie is a secure cookie.") + (http-only :initarg :http-only + :initform nil + :accessor cookie-http-only + :documentation "A generalized boolean denoting whether +this cookie is a `HttpOnly' cookie. + +This is a Microsoft extension that has been implemented in Firefox as +well. See <http://msdn2.microsoft.com/en-us/library/ms533046.aspx>.")) + (:documentation "Each COOKIE objects describes one outgoing cookie.")) + +(defmethod initialize-instance :around ((cookie cookie) &rest init-args) + "Ensure COOKIE has a correct slot-value for NAME." + (let ((name (getf init-args :name))) + (unless (http-token-p name) + (error "~S is not a legal name for a cookie." name))) + (call-next-method)) + +(defun set-cookie* (cookie &optional (reply *reply*)) + "Adds the COOKIE object COOKIE to the outgoing cookies of the +REPLY object REPLY. If a cookie with the same name +\(case-sensitive) already exists, it is replaced." + (let* ((name (cookie-name cookie)) + (place (assoc name (cookies-out reply) :test #'string=))) + (cond + (place + (setf (cdr place) cookie)) + (t + (push (cons name cookie) (cookies-out reply)) + cookie)))) + +(defun set-cookie (name &key (value "") expires path domain secure http-only (reply *reply*)) + "Creates a cookie object from the parameters provided and adds +it to the outgoing cookies of the REPLY object REPLY. If a cookie +with the name NAME \(case-sensitive) already exists, it is +replaced." + (set-cookie* (make-instance 'cookie + :name name + :value value + :expires expires + :path path + :domain domain + :secure secure + :http-only http-only) + reply)) + +(defun cookie-date (universal-time) + "Converts UNIVERSAL-TIME to cookie date format." + (and universal-time + (rfc-1123-date universal-time))) + +(defmethod stringify-cookie ((cookie cookie)) + "Converts the COOKIE object COOKIE to a string suitable for a +'Set-Cookie' header to be sent to the client." + (format nil + "~A=~A~:[~;~:*; expires=~A~]~:[~;~:*; path=~A~]~:[~;~:*; domain=~A~]~:[~;; secure~]~:[~;; HttpOnly~]" + (cookie-name cookie) + (url-encode (format nil "~A" (cookie-value cookie)) +utf-8+) + (cookie-date (cookie-expires cookie)) + (cookie-path cookie) + (cookie-domain cookie) + (cookie-secure cookie) + (cookie-http-only cookie))) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/doc/LICENSE.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/doc/LICENSE.txt Thu Feb 7 03:16:29 2008 @@ -0,0 +1,9 @@ +The Hunchentoot logo (the file `hunchentoot.gif' in this directory) +was created by Uwe von Loh and is available from his website at + + http://www.htg1.de/hunchentoot/hunchentoot.html + +It is licensed under a `Creative Commons Attribution-Share Alike 2.0 +Germany License', see + + http://creativecommons.org/licenses/by-sa/2.0/de/ Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/doc/hunchentoot.gif ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/doc/index.html ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/doc/index.html Thu Feb 7 03:16:29 2008 @@ -0,0 +1,2623 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> +<html> + +<head> + <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1"> + <title>HUNCHENTOOT - The Common Lisp web server formerly known as TBNL</title> + <style type="text/css"> + pre { padding:5px; background-color:#e0e0e0 } + h3, h4 { text-decoration: underline; } + 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; } + a:focus { text-decoration: none; padding: 1px 2px 1px 2px; border: none; } + a.none { text-decoration: none; padding: 0; } + a.none:visited { text-decoration: none; padding: 0; } + a.none:hover { text-decoration: none; border: none; padding: 0; } + a.none:focus { text-decoration: none; border: none; padding: 0; } + a.noborder { text-decoration: none; padding: 0; } + a.noborder:visited { text-decoration: none; padding: 0; } + a.noborder:hover { text-decoration: none; border: none; padding: 0; } + a.noborder:focus { text-decoration: none; border: none; padding: 0; } + pre.none { padding:5px; background-color:#ffffff } + </style> + <meta name="description" content="A fully-featured web server written in Common Lisp offering things like HTTP/1.1 chunking, persistent connections, and SSL. +Includes a framework for building dynamic websites interactively."> +</head> + +<body bgcolor=white> + +<h2><a href="http://www.htg1.de/hunchentoot/hunchentoot.html" +title="Click here for the Hunchentoot logo" +class=noborder><img align=top width=93 height=45 border=0 +src="hunchentoot.gif"></a> HUNCHENTOOT - The Common Lisp web server +formerly known as TBNL</h2> + +<blockquote> +   <h3><a name=abstract class=none>Abstract</a></h3> + +Hunchentoot is a web server written in Common Lisp and at the same +time a toolkit for building dynamic websites. As a +stand-alone web server, Hunchentoot is capable of HTTP/1.1 chunking +(both directions), persistent connections (keep-alive), and SSL, but +it can also sit behind the +popular <a href='http://httpd.apache.org/'>Apache</a> using +Marc +Battyani's <a +href='http://www.fractalconcept.com/asp/html/mod_lisp.html'>mod_lisp</a>. + + + +Hunchentoot provides facilities like automatic session handling (with +and without cookies), logging (to Apache's log files or to a file in +the file system), customizable error handling, and easy access to GET +and POST parameters sent by the client. It does not include +functionality to programmatically generate HTML output. For this task +you can use any library you like, e.g. (shameless +self-plug) <a href="http://weitz.de/cl-who/">CL-WHO</a> +or <a href="http://weitz.de/html-template/">HTML-TEMPLATE</a>. + + + +Hunchentoot talks with its front-end or with the client over TCP/IP +sockets and uses multiprocessing to handle several requests at the +same time. Therefore, it cannot be implemented completely +in <a +href="http://www.lispworks.com/documentation/HyperSpec/Front/index.htm">portable +Common Lisp</a>. It currently works with +<a href="http://www.lispworks.com/">LispWorks</a> (which is the main development and testing platform), +<a href="http://www.cons.org/cmucl/">CMUCL</a> (with MP +support), <a href="http://sbcl.sourceforge.net/">SBCL</a> (with +Unicode and <a href="http://abstractstuff.livejournal.com/26811.html">thread</a> <a href="http://common-lisp.net/pipermail/tbnl-devel/2006-November/000780.html">support</a>), +<a href="http://openmcl.clozure.com/">OpenMCL</a>, +and <a href="http://www.franz.com/products/allegrocl/">Allegro Common +Lisp</a>. (Note: You can use Hunchentoot with <a href="http://clisp.cons.org">CLISP</a> +or with a version of SBCL without threads, for example on Windows, +but this is not recommended except for development purposes.) Porting to other +CL implementations shouldn't be too hard, see the files <code>port-xxx.lisp</code> +and <code>unix-xxx.lisp</code> which comprise all the +implementation-specific code. + + + +Hunchentoot comes with a <a +href="http://www.opensource.org/licenses/bsd-license.php">BSD-style +license</a> so you can basically do with it whatever you want. + + +Hunchentoot is for example used by <a href="http://clutu.com/">clutu</a>, <a href="http://twitterbuzz.com/">TwitterBuzz</a>, +<a href="http://www.jalat.com/">Jalat</a>, <a href="http://heikestephan.de/">Heike Stephan</a>, +<a href="http://www.memetrics.com/">xOs</a>, +and <a href="http://syseng.nist.gov/moss">the</a> <a href="http://syseng.nist.gov/se-interop">NIST</a>. + + +Download shortcut: <a href="http://weitz.de/files/hunchentoot.tar.gz">http://weitz.de/files/hunchentoot.tar.gz</a>. +</blockquote> + +   <h3><a class=none name="contents">Contents</a></h3> +<ol> + <li><a href="#install">Download and installation</a> + <ol> + <li><a href='#proxy'>Hunchentoot behind a proxy</a> + <li><a href='#mod_lisp'>Hunchentoot behind mod_lisp</a> + </ol> + <li><a href="#mail">Support and mailing lists</a> + <li><a href="#example">Examples, tutorials, add-ons</a> + <li><a href="#reference">Function and variable reference</a> + <ol> + <li><a href='#servers'>Servers</a> + <li><a href='#handlers'>Handlers</a> + <li><a href='#requests'>Requests</a> + <li><a href='#replies'>Replies</a> + <li><a href='#cookies'>Cookies</a> + <li><a href='#sessions'>Sessions</a> + <li><a href='#log'>Logging and error handling</a> + <li><a href='#debug'>Debugging Hunchentoot applications</a> + <li><a href='#misc'>Miscellaneous</a> + </ol> + <li><a href="#ht-mp">The HUNCHENTOOT-MP package</a> + <li><a href="#performance">Performance</a> + <li><a href="#history">History</a> + <li><a href="#index">Symbol index</a> + <li><a href="#ack">Acknowledgements</a> +</ol> + +   <h3><a name="install" class=none>Download and installation</a></h3> + +Hunchentoot depends on a couple of other Lisp libraries which you'll need +to install first: +<ul> + <li>Pierre R. Mai's <a href='http://www.cliki.net/md5'>MD5</a>, + + <li>Kevin Rosenberg's <a href='http://www.cliki.net/cl-base64'>CL-BASE64</a>, + + <li>Janis Dzerins' <a href='http://common-lisp.net/project/rfc2388/'>RFC2388</a>, + + <li>David Lichteblau's <a href='http://common-lisp.net/project/cl-plus-ssl/'>CL+SSL</a> (unless you're using LispWorks), + + <li><a href='http://www.cliki.net/ACL-COMPAT'>ACL-COMPAT</a> (for OpenMCL only), + + <li>and my own <a href='http://weitz.de/flexi-streams/'>FLEXI-STREAMS</a> (0.12.0 or higher), <a href='http://weitz.de/chunga/'>Chunga</a>, <a href='http://weitz.de/cl-ppcre/'>CL-PPCRE</a>, and <a href='http://weitz.de/url-rewrite/'>URL-REWRITE</a> (plus <a href="http://weitz.de/cl-who/">CL-WHO</a> for the <a href="#example">example code</a>). +</ul> +Make sure to use the newest versions of all of these libraries (which might themselves depend on other libraries)! +Note: You can compile Hunchentoot without SSL support - and thus without the need to have CL+SSL - if you add <code>:HUNCHENTOOT-NO-SSL</code> to <a href="http://www.lispworks.com/documentation/HyperSpec/Body/v_featur.htm"><code>*FEATURES*</code></a> before you compile it. + +The preferred method to compile and load Hunchentoot is via <a href="http://www.cliki.net/asdf">ASDF</a>. + +Hunchentoot together with this documentation can be downloaded +from <a +href="http://weitz.de/files/hunchentoot.tar.gz">http://weitz.de/files/hunchentoot.tar.gz</a>. The +current version is 0.15.0. There's also a port +for <a href="http://www.gentoo.org/proj/en/common-lisp/index.xml">Gentoo +Linux</a> thanks to Matthew Kennedy. + +A <a href="http://www.selenic.com/mercurial/wiki/">Mercurial</a> +repository of older versions is available +at <a +href="http://arcanes.fr.eu.org/~pierre/2007/02/weitz/">http://arcanes.fr.eu.org/~pierre/2007/02/weitz/</a> +thanks to Pierre Thierry. + +Luís Oliveira maintains a <a href="http://darcs.net/">darcs</a> +repository of Hunchentoot +at <a +href="http://common-lisp.net/~loliveira/ediware/">http://common-lisp.net/~loliveira/ediware/</a>. + +<h4><a name="proxy" class=none>Hunchentoot behind a proxy</a></h4> + +If you're feeling unsecure about exposing Hunchentoot to the wild, +wild Internet or if your Lisp web application is part of a larger +website, you can hide it behind +a <a href="http://en.wikipedia.org/wiki/Proxy_server">proxy +server</a>. One approach that I have used several times is to employ +Apache's <a +href="http://httpd.apache.org/docs/2.0/mod/mod_proxy.html">mod_proxy</a> +module with a configuration that looks like this: +<pre> +<a href="http://httpd.apache.org/docs/2.0/mod/mod_proxy.html#proxypass" class=noborder>ProxyPass</a> /hunchentoot http://127.0.0.1:3000/hunchentoot +<a href="http://httpd.apache.org/docs/2.0/mod/mod_proxy.html#proxypassreverse" class=noborder>ProxyPassReverse</a> /hunchentoot http://127.0.0.1:3000/hunchentoot +</pre> +This will tunnel all requests where the URI path begins with <code>"/hunchentoot"</code> to a (Hunchentoot) server listening on port 3000 on the same machine. + +Of course, there are <a href="http://www.red-bean.com/pipermail/lispweb/2006-October/001342.html">several other</a> (more lightweight) web proxies that +you could use instead of Apache. + +<h4><a name="mod_lisp" class=none>Hunchentoot behind mod_lisp</a></h4> + +You can also couple Hunchentoot more tightly with Apache +using <a +href='http://www.fractalconcept.com/asp/html/mod_lisp.html'>mod_lisp</a>. +In this case, Apache will not send proxy requests to Hunchentoot, but +communicate with it directly using a simple, line-based protocol. The +downside of this approach is that it makes debugging harder. (Also, +with mod_lisp, +you <a +href="http://common-lisp.net/pipermail/mod-lisp-devel/2006-October/000098.html">can't +accept request bodies that use chunked encoding</a>. With the usual +web browsers, this shouldn't be a problem, though.) + +For this setup you need two things: + +<ul> + <li>The <a href='http://httpd.apache.org/'>Apache web server</a>. You can use either 1.3.x or 2.x. It is recommend that you use or build an Apache with <a href='http://httpd.apache.org/docs/dso.html'>DSO support</a>. + + <li>The <a +href='http://www.fractalconcept.com/asp/html/mod_lisp.html'>mod_lisp</a> +Apache module by Marc Battyani. It is beyond the scope of this document to explain the +details of how to install mod_lisp, but if your Apache has DSO support, +it should suffice to issue a command like + +<pre> +apxs -c -i -a mod_lisp.c +</pre> + +as root (and afterwards restart Apache). + +The newest version of mod_lisp is available from <a +href="http://www.fractalconcept.com:8000/public/open-source/mod_lisp/">http://www.fractalconcept.com:8000/public/open-source/mod_lisp/</a>. For Apache 1.3.x you +must use mod_lisp.c, for Apache 2.x you must use mod_lisp2.c, which is a reimplementation of Marc's mod_lisp by Chris Hanson. + +You can get pre-compiled modules for the Win32 version of Apache 2 (but probably not the latest version) from <a href="http://www.fractalconcept.com:8000/public/open-source/mod_lisp/windows/">http://www.fractalconcept.com:8000/public/open-source/mod_lisp/windows/</a>. Put the file into Apache's <code>modules</code> folder and add the line +<pre> +LoadModule lisp_module modules/mod_lisp2.so +</pre> +to your <code>httpd.conf</code> file. + +</ul> + +Then you will have to configure Apache and mod_lisp to make them aware +of Hunchentoot. First, in your Apache configuration file (usually +called <code>httpd.conf</code>) add these lines + +<pre> +<a name='LispServer' class=noborder>LispServer</a> 127.0.0.1 3000 "foo" + +<Location /hunchentoot> + SetHandler lisp-handler +</Location> +</pre> + +and afterwards restart Apache. This informs mod_lisp that there's a +Lisp listening on port 3000 and named +"foo" - you can of course use any other name or port or +even put Hunchentoot on another physical machine. (In the latter case you'll +have to replace <code>127.0.0.1</code> with the FQDN or IP address of +this machine.) + +The <code>Location/SetHandler</code> part means that every URL which +starts with <code>/hunchentoot</code> will be handled by mod_lisp (and thus +Hunchentoot) on this server. (Again, you can of course use other locations. See the +Apache documentation for things like virtual hosts or +directives like <code>LocationMatch</code>.) + + + +To interface a Hunchentoot server with mod_lisp, you must start it +with the <code>:MOD-LISP-P</code> keyword parameter +of <a href="#start-server"><code>START-SERVER</code></a> set to a true +value. + +   <h3><a name="mail" class=none>Support and mailing lists</a></h3> + +For questions, bug reports, feature requests, improvements, or patches +please use +the <a +href="http://common-lisp.net/mailman/listinfo/tbnl-devel">tbnl-devel +mailing list</a>. If you want to be notified about future releases +subscribe to +the <a +href="http://common-lisp.net/mailman/listinfo/tbnl-announce">tbnl-announce +mailing list</a>. These mailing lists were made available thanks to +the services of <a href="http://common-lisp.net/">common-lisp.net</a>. +You can search the devel mailing +list <a +href="http://google.com/coop/cse?cx=002927904911724867201%3A0l5rif_cxj0">here</a> +(thanks to Tiarn�n � Corr�in). + +If you want to send patches, please <a href="http://weitz.de/patches.html">read this first</a>. + +   <h3><a name="example" class=none>Examples, tutorials, add-ons</a></h3> + +Hunchentoot comes with an example website which you can use to see if +it works and which should also demonstrate a couple of the things you +can do with Hunchentoot. Use it as a kind of "Hello World" code to +get yourself started. + +To run the example, +enter the following code into your listener: +<pre> +(<a class=noborder href="http://common-lisp.net/~mmommer/asdf-howto.shtml#sec11">asdf:oos</a> 'asdf:load-op :hunchentoot-test) +(hunchentoot:<a class=noborder href="#start-server">start-server</a> :port 4242) +</pre> +You should now be able to point your browser +at <code>http://localhost:4242/hunchentoot/test</code> and see +something. + +Here are some tutorials done by others: +<ul> +<li>Two <a href="http://myblog.rsynnott.com/2007/09/getting-started-with-hunchento.html">getting</a> <a href="http://myblog.rsynnott.com/2007/10/doing-more-with-hunchentoot-cl-server.ht…">started</a> articles by Robert Synnott. +<li><a href="http://www.newartisans.com/blog_files/common.lisp.with.apache.php">Running Common Lisp behind Apache</a> by John Wiegley. +<li>A <a href="http://www.lispcast.com/index.php/2007/10/lispcast-writing-a-simple-reddit-…">"LispCast"</a> by Eric Normand about writing a <a href="http://reddit.com/">Reddit</a> clone using Hunchentoot. Apparently the first part of a <a href="http://bc.tech.coop/blog/071028.html">series</a>. +<li>A <a +href="http://www.jalat.com/blogs/lisp?id=3">tutorial</a> for (an older version of) Hunchentoot by Asbjørn Bjørnstad. +<li>A <a href="http://www.frank-buss.de/lisp/tbnl.html">TBNL +tutorial</a> from Frank Buss. (Hunchentoot is not <a href="http://weitz.de/tbnl/">TBNL</a>, but the two +are similar enough to make the tutorial worthwhile.) +<li> +For Win32, Bill Clementson +<a +href="http://bc.tech.coop/blog/041105.html">explains</a> how to set up Hunchentoot's predecessor <a href="http://weitz.de/tbnl/">TBNL</a> with +Apache/mod_lisp. See also <a href="http://bc.tech.coop/blog/061013.html">http://bc.tech.coop/blog/061013.html</a>. +</ul> +Check the dates of these tutorials. Some of them might not be a +perfect fit with the latest release of Hunchentoot. Also, the fact +that these tutorials are listed here doesn't necessarily mean that I +endorse them or think that they show idiomatic Lisp code. You'll have +to decide yourself if they're helpful to you or not. + + +Here is some software which extends Hunchentoot or is based on it: +<ul> +<li><a href="http://common-lisp.net/project/cl-weblocks/">Weblocks</a> +by Slava Akhmechet is a "continuations-based web framework" which is +based on Hunchentoot. +<li><a href="http://85.65.214.241/misc/ht-ajax.html">HT-AJAX</a> is +an <a +href="http://en.wikipedia.org/wiki/Ajax_%28programming%29">Ajax</a> +framework for Hunchentoot by Ury Marshak. +<li>Mac +Chan <a +href="http://common-lisp.net/pipermail/tbnl-devel/2007-May/001324.html">has +ported <a href="http://lemonodor.com/">John +Wiseman</a>'s <a +href="http://www.lemonodor.com/archives/000128.html">Lisp Server +Pages</a> to Hunchentoot. +<li><a +href="http://site.znain.com/dl/lisp/hunchentoot-dir-lister/">hunchentoot-dir-lister</a> +is a directory listing addition for Hunchentoot by Dimitre Liotev. +<li>Cyrus +Harmon's <a +href="http://cyrusharmon.org/blog/display?id=64">nuclblog</a> is a +<a href="http://en.wikipedia.org/wiki/Blog">blog</a> engine which uses Hunchentoot. +<li><a href="http://weitz.de/cl-webdav/">CL-WEBDAV</a> is a <a href="http://webdav.org/">WebDAV</a> server based on Hunchentoot. +</ul> + +   <h3><a class=none name="reference">Function and variable reference</a></h3> + +<h4><a class=none name="servers">Servers</a></h4> + +If you want Hunchentoot to actually do something, you have +to <a href="#start-server">start</a> a server. You can also run +several servers in one image, each one listening to a different port. + + [Function] + <a class=none name="start-server">start-server <tt>&key</tt> port address name dispatch-table mod-lisp-p use-apache-log-p input-chunking-p read-timeout write-timeout setuid setgid ssl-certificate-file ssl-privatekey-file ssl-privatekey-password => server</a> + +<blockquote> Starts a Hunchentoot server instance and returns it. +<code>port</code> ist the port the server will be listening on +- the default is 80 (or 443 if SSL information is provided). +If <code>address</code> is a string denoting an IP address, +then the server only receives connections for that address. This must +be one of the addresses associated with the machine and allowed values +are host names such as <a class=none href="http://www.zappa.com/"><code>"www.zappa.com"</code></a> and address +strings such as <a class=none href="http://72.3.247.29/"><code>"72.3.247.29"</code></a>. +If <code>address</code> is <code>NIL</code>, then the server +will receive connections to all IP addresses on the machine. This is +the default. + +<code>dispatch-table</code> can either be +a <a href="#*dispatch-table*">dispatch table</a> which is to be used +by this server or <code>NIL</code> which means that at request +time <a href="#*meta-dispatcher*"><code>*META-DISPATCHER*</code></a> +will be called to retrieve a dispatch table. + +<code>name</code> should be a symbol which can be used to name +the server. This name can utilized when +defining <a href="#define-easy-handler">easy handlers</a>. The +default name is an uninterned symbol as returned +by <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/f_gensym.htm"><code>GENSYM</code></a>. + +If <code>mod-lisp-p</code> is true (the default +is <code>NIL</code>), the server will act as a back-end +for <a href="#mod_lisp">mod_lisp</a>, otherwise it will be a +stand-alone web server. If <code>use-apache-log-p</code> is +true (which is the default), log messages will be written to the +Apache log file - this parameter has no effect +if <code>mod-lisp-p</code> is NIL. + +If <code>input-chunking-p</code> is true (which is the +default), the server will accept request bodies without +a <code>Content-Length</code> header if the client uses chunked +transfer encoding. If you want to use this feature behind mod_lisp, +you should make sure that your combination of Apache and +mod_lisp <a +href="http://common-lisp.net/pipermail/mod-lisp-devel/2006-December/000104.html">can +cope with that</a>. + +<code>read-timeout</code> is the read timeout (in seconds) for +the socket stream used by the server - the default value +is <a +href="#*default-read-timeout*"><code>*DEFAULT-READ-TIMEOUT*</code></a>. +This parameter is ignored on OpenMCL. <code>write-timeout</code> is the write timeout (in +seconds) for the socket stream used by the server - the default value +is <a +href="#*default-write-timeout*"><code>*DEFAULT-WRITE-TIMEOUT*</code></a>. +This parameter is ignored on all implementations except for +LispWorks 5.0 or higher and AllegroCL. You can use <code>NIL</code> in both +cases to denote that you don't want a timeout. +If <code>mod-lisp-p</code> is true, the timeouts are always set +to <code>NIL</code>. + +On Unix you can use <code>setuid</code> +and <code>setgid</code> 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.) <code>setuid</code> and +<code>setgid</code> can be integers (the actual IDs) or strings +(for the user and group name respectively). + +If you want your server to use SSL, you must provide the pathname +designator(s) <code>ssl-certificate-file</code> for the certificate file and +optionally <code>ssl-privatekey-file</code> for the private key file, both files +must be in PEM format. If you only provide the value for +<code>ssl-certificate-file</code> it is assumed that both the +certificate and the private key are in one file. If your private key +needs a password you can provide it through +the <code>ssl-privatekey-password</code> keyword argument. If +you don't use LispWorks, the private key must not be +associated with a password, and the certificate and the private key +must be in separate files. +</blockquote> + + [Function] + <a class=none name="stop-server">stop-server server => |</a> + +<blockquote> +Stops a server started with <a href="#start-server"><code>START-SERVER</code></a>. <code>server</code> must be an object as returned by <a href="#start-server"><code>START-SERVER</code></a>. +</blockquote> + + [Special variable] + <a class=none name="*server*">*server*</a> + +<blockquote> +During the execution of <a href="#handlers">dispatch functions and handlers</a> this variable +is bound to the server object (as returned by <a href="#start-server"><code>START-SERVER</code></a>) which processes the request. +</blockquote> + + [Readers] + <a class=none name="server-local-port">server-local-port server => port</a> + <a class=none name="server-address">server-address server => address</a> + +<blockquote> +These methods can be used to query a Hunchentoot server object. The values correspond to the <code>port</code> and <code>address</code> parameters of <a href="#start-server"><code>START-SERVER</code></a>. +</blockquote> + + [Accessor] + <a class=none name="server-dispatch-table">server-dispatch-table server => dispatch-table + <tt>(setf (</tt>server-dispatch-table server) new-value<tt>)</tt></a> + +<blockquote> These methods can be used to get and set +the <a href="#*dispatch-table*">dispatch table</a> of a Hunchentoot +server object. The value corresponds to +the <code>dispatch-table</code> parameter +of <a href="#start-server"><code>START-SERVER</code></a> and can be +changed at runtime. It can be set to NIL which means that the server +doesn't have its own dispatch table +and <a href="#*meta-dispatcher*"><code>*META-DISPATCHER*</code></a> should be +called instead. +</blockquote> + + [Accessor] + <a class=none name="server-name">server-name server => name + <tt>(setf (</tt>server-name server) new-value<tt>)</tt></a> +<blockquote> These methods can be used to get and set the name of a server +which must be a symbol. +</blockquote> + + [Special variable] + <a class=none name="*default-read-timeout*">*default-read-timeout*</a> + +<blockquote> The default value for the <code>read-timeout</code> keyword +argument to <a href="#start-server"><code>START-SERVER</code></a>. The initial value is 20 (seconds). +</blockquote> + + [Special variable] + <a class=none name="*default-write-timeout*">*default-write-timeout*</a> + +<blockquote> The default value for the <code>write-timeout</code> keyword +argument to <a href="#start-server"><code>START-SERVER</code></a>. The initial value is 20 (seconds). +</blockquote> + + [Special variable] + <a class=none name="*cleanup-interval*">*cleanup-interval*</a> + +<blockquote> +Should be <code>NIL</code> or a positive integer. The system calls +<a href="#*cleanup-function*"><code>*CLEANUP-FUNCTION*</code></a> whenever <a href="#*cleanup-interval*"><code>*CLEANUP-INTERVAL*</code></a> new worker threads have +been created unless the value is <code>NIL</code>. The initial value is 100. +</blockquote> + + [Special variable] + <a class=none name="*cleanup-function*">*cleanup-function*</a> + +<blockquote> +The function (with no arguments) which is called if <a href="#*cleanup-interval*"><code>*CLEANUP-INTERVAL*</code></a> is not <code>NIL</code>. +The initial value is a function which calls +<code>(<a href="http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-166.htm">HCL</a>:<a href="http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-212.htm"><code>MARK-AND-SWEEP</code></a> 2)</code> on LispWorks and does nothing on other Lisps. + +On LispWorks this is necessary because each worker (which is +created to handle an incoming http request and which dies afterwards +unless the connection is persistent) is a Lisp process and LispWorks +creates processes in generation 2. + +Note that you can also set this value to <code>NIL</code> and tune +LispWork's GC yourself, using for +example <a +href="http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-180.htm"><code>COLLECT-GENERATION-2</code></a>. +</blockquote> + +<h4><a class=none name="handlers">Handlers</a></h4> + +Hunchentoot handles each incoming request dynamically depending on the +contents of a global dispatch table. The details can be found +below. (See the file <code>test/test.lisp</code> for examples.) + + [Special variable] + <a class=none name="*dispatch-table*">*dispatch-table*</a> + +<blockquote> + +The return value of the initial value of <a href="#*meta-dispatcher*"><code>*META-DISPATCHER*</code></a>. + +This is a list of <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function…">function +designators</a> for dispatch functions each of which should +be a function of one argument which accepts a <a +href='#requests'><code>REQUEST</code></a> object and, depending on +this object, should either return a handler to handle the +request or <code>NIL</code> which means that the next dispatcher will +be queried. A handler is a designator for a function with no +arguments which usually returns a string or an array of octets to be sent to the client as +the body of the http reply. (Note that if you use symbols as function +designators, you can redefine your handler functions without the need +to change the dispatch functions.) See <a href='#replies'>the section +about replies</a> for more about what handlers can do. + +The dispatchers in a dispatch table are tried in turn +until one of them returns a handler. If this doesn't happen, Hunchentoot will +return a 404 status code (Not Found) to the client. + +The initial value of <code>*DISPATCH-TABLE*</code> is a list which +just contains the symbol <a +href='#default-dispatcher'><code>DEFAULT-DISPATCHER</code></a>. + +</blockquote> + + [Function] + <a class=none name="default-dispatcher">default-dispatcher request => handler</a> + +<blockquote> + +This is a function which will always unconditionally return the value of <a +href='#*default-handler*'><code>*DEFAULT-HANDLER*</code></a>. It is intended to be the last element of <a +href='#*dispatch-table*'><code>*DISPATCH-TABLE*</code></a>. + +</blockquote> + + [Special variable] + <a class=none name="*default-handler*">*default-handler*</a> + +<blockquote> + +This variable holds the handler which is always returned by <a +href='#default-dispatcher'><code>DEFAULT-DISPATCHER</code></a>. The +default value is a function which unconditonally shows a short Hunchentoot +info page. + +</blockquote> + + [Special variable] + <a class=none name="*meta-dispatcher*">*meta-dispatcher*</a> + +<blockquote> The value of this variable should be a function of +one argument. It is called with the current Hunchentoot server +instance (unless the server has <a href="#server-dispatch-table">its +own dispatch table</a>) and must return a dispatch table suitable for +Hunchentoot. The initial value is a function which always +unconditionally returns +<a href="#*dispatch-table*"><code>*DISPATCH-TABLE*</code></a>. + +This can obviously be used to assign different dispatch tables to +different servers (and is useless if you only have one server). +</blockquote> + + [Function] + <a class=none name="create-prefix-dispatcher">create-prefix-dispatcher prefix handler => dispatch-fn</a> + +<blockquote> + +A convenience function which will return a dispatcher that returns <code>handler</code> whenever the path part of the request URI starts with the string <code>prefix</code>. + +</blockquote> + + [Function] + <a class=none name="create-regex-dispatcher">create-regex-dispatcher regex handler => dispatch-fn</a> + +<blockquote> + +A convenience function which will return a dispatcher that returns <code>handler</code> whenever the path part of the request URI matches the <a href='http://weitz.de/cl-ppcre/'>CL-PPCRE</a> regular expression <code>regex</code> (which can be a string, an s-expression, or a scanner). + +</blockquote> + + [Function] + <a class=none name="handle-static-file">handle-static-file path <tt>&optional</tt> content-type => nil</a> + +<blockquote> +Sends the file denote by the pathname designator +<code>path</code> with content type +<code>content-type</code> to the client. Sets the necessary handlers. In particular the function employs +<a href="#handle-if-modified-since"><code>HANDLE-IF-MODIFIED-SINCE</code></a>. + +If <code>content-type</code> is <code>NIL</code> the function +tries to determine the correct content type from the file's suffix or +falls back to <code>"application/octet-stream"</code> as a last resort. + +Note that this function +calls <a href="#send-headers"><code>SEND-HEADERS</code></a> +internally, so after you've called it, the headers are sent and the +return value of your handler is ignored. +</blockquote> + + [Function] + <a class=none name="create-static-file-dispatcher-and-handler">create-static-file-dispatcher-and-handler uri path <tt>&optional</tt> content-type => dispatch-fn</a> + +<blockquote> + +A convenience function which will return a dispatcher that dispatches +to a handler which emits the file denoted by the pathname designator +<code>path</code> with content type +<code>content-type</code> +if the <a href='#script-name'><code>SCRIPT-NAME</code></a> of the +request matches the string <code>uri</code>. Uses <a href="#handle-static-file"><code>HANDLE-STATIC-FILE</code></a> internally. + +If <code>content-type</code> is <code>NIL</code> the function tries to determine the correct content type from the file's suffix +or falls back to <code>"application/octet-stream"</code> as a last resort. +<a href='#*default-content-type*'><code>*DEFAULT-CONTENT-TYPE*</code></a>. +</blockquote> + + [Function] + <a class=none name="create-folder-dispatcher-and-handler">create-folder-dispatcher-and-handler uri-prefix base-path <tt>&optional</tt> content-type => dispatch-fn</a> + +<blockquote> +Creates and returns a dispatch function which will dispatch to a +handler function which emits the file relative to <code>base-path</code> that is +denoted by the URI of the request relative to <code>uri-prefix</code>. <code>uri-prefix</code> +must be a string ending with a slash, <code>base-path</code> must be a pathname +designator for an existing directory. +Uses <a href="#handle-static-file"><code>HANDLE-STATIC-FILE</code></a> internally. + +If <code>content-type</code> is not <code>NIL</code>, +it will be used as a the content type for all files in the folder. +Otherwise (which is the default) the content type of each file will be determined <a href="#handle-static-file">as usual</a>. +</blockquote> + + [Generic function] + <a class=none name="dispatch-request">dispatch-request dispatch-table => result</a> + +<blockquote> +This is a generic function so users can customize its behaviour. Look at the source code for details. +</blockquote> + + [Macro] + <a class=none name="define-easy-handler">define-easy-handler description lambda-list [[declaration* | documentation]] form*</a> + +<blockquote> + +Defines a handler as if +by <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/m_defun.htm"><code>DEFUN</code></a> +and optionally registers it with a URI so that it will be found +by <a +href="#dispatch-easy-handlers"><code>DISPATCH-EASY-HANDLERS</code></a>. + +<code>description</code> is either a symbol <code>name</code> or a list matching the +<a href="http://www.lispworks.com/documentation/HyperSpec/Body/03_de.htm">destructuring lambda list</a> + +<pre> + (name &key uri server-names default-parameter-type default-request-type). +</pre> + +<code>lambda-list</code> is a list the elements of which are either a symbol +<code>var</code> or a list matching the destructuring lambda list + +<pre> + (var &key real-name parameter-type init-form request-type). +</pre> + +The resulting handler will be a Lisp function with the +name <code>name</code> and keyword parameters named by +the <code>var</code> symbols. Each <code>var</code> +will be bound to the value of the GET or POST parameter +called <code>real-name</code> (a string) before the body of the +function is executed. If <code>real-name</code> is not +provided, it will be computed by <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_stg_up.htm#string-d…">downcasing</a> the symbol name +of <code>var</code>. + +If <code>uri</code> (which is evaluated) is provided, then it must be a string or +a <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function…">function +designator</a> for a unary function. In this case, +the handler will be returned by <a href="#dispatch-easy-handlers"><code>DISPATCH-EASY-HANDLERS</code></a>, if <code>uri</code> is a +string and the <a href="#script-name">script name</a> of the current request is <code>uri</code>, or if <code>uri</code> designates a +function and applying this function to the <a href="#*request*">current <code>REQUEST</code> object</a> +returns a true value. + + +<code>server-names</code> (which is evaluated) can be a list of +symbols which means that the handler will only be returned +by <a +href="#dispatch-easy-handlers"><code>DISPATCH-EASY-HANDLERS</code></a> +in servers which have one of these names +(see <a +href="#server-name"><code>SERVER-NAME</code></a>). <code>server-names</code> +can also be the symbol <code>T</code> which means that the handler +will be returned +by <a +href="#dispatch-easy-handlers"><code>DISPATCH-EASY-HANDLERS</code></a> +in every server. + +Whether the GET or POST parameter (or both) will be taken into +consideration, depends on <code>request-type</code> which can +be <code>:GET</code>, <code>:POST</code>, <code>:BOTH</code>, or <code>NIL</code>. In the last case, the value of +<code>default-request-type</code> (the default of which +is <code>:BOTH</code>) will be used. + +The value of <code>var</code> will usually be a string (unless +it resulted from a <a href="#upload">file upload</a> in which case it won't be converted at +all), but if <code>parameter-type</code> (which is evaluated) +is provided, the string will be converted to another Lisp type by the +following rules: + +If the corresponding GET or POST parameter wasn't provided by the +client, <code>var</code>'s value will be <code>NIL</code>. If <code>parameter-type</code> is <code>'STRING</code>, +<code>var</code>'s value remains as is. If <code>parameter-type</code> is <code>'INTEGER</code> and the +parameter string consists solely of decimal digits, <code>var</code>'s value will be +the corresponding integer, otherwise <code>NIL</code>. If <code>parameter-type</code> is +<code>'KEYWORD</code>, <code>var</code>'s value will be the +keyword obtained +by <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/f_intern.htm">interning</a> +the <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_stg_up.htm#string-u…">upcased</a> parameter string into +the <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/11_abc.htm">keyword +package</a>. If <code>parameter-type</code> +is <code>'CHARACTER</code> and the parameter string is of length +one, <code>var</code>'s value will be the single character of +this string, otherwise <code>NIL</code>. +If <code>parameter-type</code> +is <code>'BOOLEAN</code>, <code>var</code>'s value will always +be <code>T</code> (unless it is <code>NIL</code> by the first rule +above, of course). If <code>parameter-type</code> is any other +atom, it is supposed to be +a <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function…">function +designator</a> for a unary function which will be called to +convert the string to something else. + +Those were the rules for simple parameter types, but +<code>parameter-type</code> can also be a list starting with one of the symbols +<code>LIST</code>, <code>ARRAY</code>, or <code>HASH-TABLE</code>. +The second value of the list must always be a simple parameter type as +in the last paragraph - we'll call it the inner type below. + +In the case of <code>'LIST</code>, all GET/POST parameters +called <code>real-name</code> will be collected, converted to +the inner type as by the rules above, and assembled into a list which +will be the value of +<code>var</code>. + +In the case of <code>'ARRAY</code>, all GET/POST parameters which have +a name like the result of + +<pre> + (format nil "~A[~A]" real-name n) +</pre> + +where <code>n</code> is a non-negative integer, will be +assembled into an array where the <code>n</code>th element will +be set accordingly, after conversion to the inner type. The array, +which will become the value of <code>var</code>, will be big +enough to hold all matching parameters, but not bigger. Array +elements not set as described above will be <code>NIL</code>. Note +that <code>VAR</code> will always be bound to an array, which may be +empty, so it will never be <code>NIL</code>, even if no appropriate +GET/POST parameters are found. + +The full form of a <code>'HASH-TABLE</code> parameter type is + +<pre> + (hash-table inner-type key-type test-function), +</pre> + +but <code>key-type</code> and <code>test-function</code> +can be left out in which case they default to <code>'STRING</code> +and <code>'EQUAL</code>, respectively. For this parameter type, all +GET/POST parameters which have a name like the result of + +<pre> + (format nil "~A{~A}" real-name key) +</pre> + +(where <code>key</code> is a string that doesn't contain curly brackets) will +become the values (after conversion to <code>inner-type</code>) of a hash +table with test function <code>test-function</code> where <code>key</code> (after +conversion to <code>key-type</code>) will be the corresponding key. Note that +<code>var</code> will always be bound to a hash table, which +may be empty, so it will never be <code>NIL</code>, even if no +appropriate GET/POST parameters are found. + +To make matters even more complicated, the three compound parameter +types also have an abbreviated form - just one of the +symbols <code>LIST</code>, <code>ARRAY</code>, +or <code>HASH-TABLE</code>. In this case, the inner type will default +to <code>'STRING</code>. + +If <code>parameter-type</code> is not provided +or <code>NIL</code>, <code>default-parameter-type</code> (the +default of which is <code>'STRING</code>) will be used instead. + +If the result of the computations above would be +that <code>var</code> would be bound to <code>NIL</code>, +then <code>init-form</code> (if provided) will be evaluated +instead, and <code>var</code> will be bound to the result of +this evaluation. + +Handlers built with this macro are constructed in such a way that the +resulting Lisp function is useful even outside of Hunchentoot. Specifically, +all the parameter computations above will only happen +if <a href="#*request*"><code>*REQUEST*</code></a> is bound, i.e. if +we're within a Hunchentoot request. Otherwise, <code>var</code> will +always be bound to the result of +evaluating <code>init-form</code> unless a corresponding +keyword argument is provided. + +The <a href="#example">example code</a> that comes with Hunchentoot contains an +example which demonstrates some of the features +of <a +href="#define-easy-handler"><code>DEFINE-EASY-HANDLER</code></a>. + +</blockquote> + + [Function] + <a class=none name="dispatch-easy-handlers">dispatch-easy-handlers request => handler</a> + +<blockquote> + +This is a dispatcher which returns the appropriate handler defined +with <a +href="#define-easy-handler"><code>DEFINE-EASY-HANDLER</code></a>, if +there is one. The newest handlers are checked +first. <a +href="#define-easy-handler"><code>DEFINE-EASY-HANDLER</code></a> makes +sure that there's always only one handler per name and one per URI. +URIs are compared +by <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/f_equal.htm"><code>EQUAL</code></a>, +so anonymous functions won't be recognized as being identical. + +</blockquote> + +<h4><a class=none name="requests">Requests</a></h4> + +When a request comes in, Hunchentoot creates a <code>REQUEST</code> object +which is available to the <a href="#handlers">handler</a> via the +special variable <a href='#*request*'><code>*REQUEST*</code></a>. This object holds +all the information available about the request and can be queried +with the functions described in this chapter. Note that the internal +structure of <code>REQUEST</code> objects should be considered opaque and may change +in future releases of Hunchentoot. + +In all of the functions below, the default value +for <code>request</code> (which is either an optional or a +keyword argument) is the value of <a href='#*request*'><code>*REQUEST*</code></a>, +i.e. handlers will usually not need to provide this argument when +calling the function. + +(Some of the function names in this section might seem a bit strange. +This is because they were initially chosen to be similar to +environment variables in CGI scripts.) + + [Special variable] + <a class=none name="*request*">*request*</a> + +<blockquote> + +Holds the current <code>REQUEST</code> object. + +</blockquote> + + [Function] + <a class=none name="host">host <tt>&optional</tt> request => string</a> + +<blockquote> + +Returns the value of the incoming <code>Host</code> http header. +(This corresponds to +the environment variable <code>HTTP_HOST</code> in CGI +scripts.) + +</blockquote> + + [Function] + <a class=none name="request-method">request-method <tt>&optional</tt> request => keyword</a> + +<blockquote> + +Returns the request method as a keyword, i.e. something like <code>:POST</code>. (This corresponds to the environment +variable <code>REQUEST_METHOD</code> in CGI scripts.) + +</blockquote> + + [Function] + <a class=none name="request-uri">request-uri <tt>&optional</tt> request => string</a> + +<blockquote> + +Returns the URI for <code>request</code>. Note that this not the full URI but only the part behind the +scheme and authority components, so that if the user has typed <code>http://user:password@www.domain.com/xxx/frob.html?foo=bar</code> into his browser, this function will return <code>"/xxx/frob.html?foo=bar"</code>. +(This corresponds to +the environment variable <code>REQUEST_URI</code> in CGI +scripts.) + +</blockquote> + + [Function] + <a class=none name="script-name">script-name <tt>&optional</tt> request => string</a> + +<blockquote> + +Returns the file name (or path) component of the URI +for <code>request</code>, i.e. the part of the string returned +by <a href="#request-uri"><code>REQUEST-URI</code></a> in front of the +first question mark (if any). +(This corresponds to +the environment variable <code>SCRIPT_NAME</code> in CGI +scripts.) + +</blockquote> + + [Function] + <a class=none name="query-string">query-string <tt>&optional</tt> request => string</a> + +<blockquote> + +Returns the query component of the URI +for <code>request</code>, i.e. the part of the string returned +by <a href="#request-uri"><code>REQUEST-URI</code></a> behind the +first question mark (if any). +(This corresponds to +the environment variable <code>QUERY_STRING</code> in CGI +scripts.) See also <a href="#get-parameter"><code>GET-PARAMETER</code></a> and <a href="#get-parameters"><code>GET-PARAMETERS</code></a>. + +</blockquote> + + [Function] + <a class=none name="get-parameter">get-parameter name <tt>&optional</tt> request => string</a> + +<blockquote> +Returns the value of the GET parameter (as provided via the request URI) named by the string <code>name</code> as a string (or <code>NIL</code> if there ain't no GET parameter with this name). Note that only the first value will be returned if the client provided more than one GET parameter with the name <code>name</code>. See also <a href="#get-parameters"><code>GET-PARAMETERS</code></a>. +</blockquote> + + [Function] + <a class=none name="get-parameters">get-parameters <tt>&optional</tt> request => alist</a> + +<blockquote> +Returns an <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> of all GET parameters (as provided via the request URI). The <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#car">car</a> of each element of this list is the parameter's name while the <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#cdr">cdr</a> is its value (as a string). The elements of this list are in the same order as they were within the request URI. See also <a href="#get-parameter"><code>GET-PARAMETER</code></a>. +</blockquote> + + [Function] + <a class=none name="post-parameter">post-parameter name <tt>&optional</tt> request => string</a> + +<blockquote> +Returns the value of the POST parameter (as provided in the request's body) named by the string <code>name</code>. Note that only the first value will be returned if the client provided more than one POST parameter with the name <code>name</code>. +This value will usually be a string (or <code>NIL</code> if there ain't no POST parameter with this name). If, however, the browser sent a <a class=none name="upload">file</a> through a <a href="http://www.faqs.org/rfcs/rfc2388.html"><code>multipart/form-data</code></a> form, the value of this function is a three-element list +<pre> +(path file-name content-type) +</pre> +where <code>path</code> is a pathname denoting the place were the uploaded file was stored, <code>file-name</code> (a string) is the file name sent by the browser, and <code>content-type</code> (also a string) is the content type sent by the browser. The file denoted by <code>path</code> will be deleted after the request has been handled - you have to move or copy it somewhere else if you want to keep it. + +POST parameters will only be computed if the content type of the request body was <code>multipart/form-data</code> +or <code>application/x-www-form-urlencoded</code>. +Although this function is called <code>POST-PARAMETER</code>, you can instruct Hunchentoot to compute these parameters for other request methods by setting <a href="#*methods-for-post-parameters*"><code>*METHODS-FOR-POST-PARAMETERS*</code></a>. + +See also <a href="#post-parameters"><code>POST-PARAMETERS</code></a> and <a href="#*tmp-directory*"><code>*TMP-DIRECTORY*</code></a>. +</blockquote> + + [Function] + <a class=none name="post-parameters">post-parameters <tt>&optional</tt> request => alist</a> + +<blockquote> +Returns an <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> of all POST parameters (as provided via the request's body). The <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#car">car</a> of each element of this list is the parameter's name while the <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#cdr">cdr</a> is its value. The elements of this list are in the same order as they were within the request's body. + +See also <a href="#post-parameter"><code>POST-PARAMETER</code></a>. +</blockquote> + + [Special variable] + <a class=none name="*methods-for-post-parameters*">*methods-for-post-parameters*</a> + +<blockquote> A list of the request method types (as keywords) for +which Hunchentoot will try to compute <a href="#post-parameter">"POST" +parameters</a>. The default is the list with the single +element <code>:POST</code>. +</blockquote> + + [Special variable] + <a class=none name="*file-upload-hook*">*file-upload-hook*</a> + +<blockquote> If this is not <code>NIL</code>, it should be +a <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function…">designator</a> +for a unary function which will be called with a pathname for each +file which is <a href="#upload">uploaded</a> to Hunchentoot. The pathname +denotes the temporary file to which the uploaded file is written. The +hook is called directly before the file is created. At this +point, <a href="#*request*"><code>*REQUEST*</code></a> is already +bound to the current <code>REQUEST</code> object, but obviously you +can't access the post parameters yet. +</blockquote> + + [Function] + <a class=none name="raw-post-data">raw-post-data <tt>&key</tt> request external-format force-text force-binary want-stream => raw-body-or-stream</a> + +<blockquote> Returns the content sent by the client in the request +body if there was any (unless the content type +was <code>multipart/form-data</code> in which case <code>NIL</code> +is returned). By default, the result is a string if the type of +the <code>Content-Type</code> <a +href="http://www.faqs.org/rfcs/rfc1590.html">media type</a> +is <code>"text"</code>, and a vector of octets otherwise. In the case +of a string, the external format to be used to decode the content will +be determined from the <code>charset</code> parameter sent by the +client (or +otherwise <a +href="#*hunchentoot-default-external-format*"><code>*HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*</code></a> +will be used). + +You can also provide an external format explicitly (through +<code>external-format</code>) in which case the result will +unconditionally be a string. Likewise, you can provide a true value +for <code>force-text</code> which will force Hunchentoot to act +as if the type of the media type had been <code>"text"</code> +(with <code>external-format</code> taking precedence if +provided). Or you can provide a true value +for <code>force-binary</code> which means that you want a +vector of octets at any rate. (If both +<code>force-text</code> and <code>force-binary</code> +are true, an error will be signaled.) + +If, however, you provide a true value +for <code>want-stream</code>, the other parameters are ignored +and you'll get the content (flexi) stream to read from it yourself. +It is then your responsibility to read the correct amount of data, +because otherwise you won't be able to return a response to the +client. The stream will have +its <a href="http://weitz.de/flexi-streams/#flexi-streams">octet +position</a> set to <code>0</code>. If the client provided +a <code>Content-Length</code> header, the stream will also have +a +corresponding <a href="http://weitz.de/flexi-streams/#flexi-streams">bound</a>, +so no matter whether the client used chunked encoding or not, you can +always read until EOF. + +If the content type of the request +was <code>multipart/form-data</code> +or <code>application/x-www-form-urlencoded</code>, the content has +been read by Hunchentoot already and you can't read from the stream +anymore. + +You can call <a href="#raw-post-data"><code>RAW-POST-DATA</code></a> +more than once per request, but you can't mix calls which have +different values for <code>want-stream</code>. + +Note that this function is slightly misnamed because a client can send +content even if the request method is not POST. +</blockquote> + + [Function] + <a class=none name="parameter">parameter name <tt>&optional</tt> request => string</a> + +<blockquote> +Returns the value of the GET or POST parameter named by the string <code>name</code> as a string (or <code>NIL</code> if there ain't no parameter with this name). If both a GET and a POST parameter with the name <code>name</code> exist, the GET parameter will be returned. See also <a href="#get-parameter"><code>GET-PARAMETER</code></a> and <a href="#post-parameter"><code>POST-PARAMETER</code></a>. +</blockquote> + + [Function] + <a class=none name="header-in">header-in name <tt>&optional</tt> request => string</a> + +<blockquote> Returns the incoming header named by the +keyword <code>name</code> as a string (or <code>NIL</code> if +there ain't no header with this name). Note that this queries the +headers sent to Hunchentoot by the client or by mod_lisp. In +the latter case this may not only include the incoming http headers +but also +some <a href='http://www.fractalconcept.com/asp/debug'>headers sent by +mod_lisp</a>. +For backwards compatibility, <code>name</code> +can also be a string which is matched case-insensitively. See +also <a href="#headers-in"><code>HEADERS-IN</code></a>. +</blockquote> + + [Function] + <a class=none name="headers-in">headers-in <tt>&optional</tt> request => alist</a> + +<blockquote> +Returns an <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> of all incoming headers. The <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#car">car</a> of each element of this list is the headers's name (a Lisp keyword) while the <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#cdr">cdr</a> is its value (as a string). There's no guarantee about the order of this list. See also <a href="#header-in"><code>HEADER-IN</code></a> and the remark about incoming headers there. +</blockquote> + + [Function] + <a class=none name="authorization">authorization <tt>&optional</tt> request => user, password</a> + +<blockquote> +Returns as two values the user and password (if any) from the incoming <code>Authorization</code> http header. Returns <code>NIL</code> if there is no such header. +</blockquote> + + + [Function] + <a class=none name="remote-addr">remote-addr <tt>&optional</tt> request => string</a> + +<blockquote> + +Returns the IP address (as a string) of the client which sent the +request. (This corresponds to the environment +variable <code>REMOTE_ADDR</code> in CGI scripts.) See +also <a href="#real-remote-addr"><code>REAL-REMOTE-ADDR</code></a>. + +</blockquote> + + [Function] + <a class=none name="remote-port">remote-port <tt>&optional</tt> request => number</a> + +<blockquote> + +Returns the IP port (as a number) of the client which sent the request. + +</blockquote> + + [Function] + <a class=none name="real-remote-addr">real-remote-addr <tt>&optional</tt> request => string{, list}</a> + +<blockquote> + +Returns the value of the +incoming <a +href="http://en.wikipedia.org/wiki/XFF"><code>X-Forwarded-For</code></a> +http header as the second value in the form of a list of IP addresses +and the first element of this list as the first value if this header +exists. Otherwise returns the value +of <a href="#remote-addr"><code>REMOTE-ADDR</code></a> as the only +value. + +</blockquote> + + [Function] + <a class=none name="server-addr">server-addr <tt>&optional</tt> request => string</a> + +<blockquote> + +Returns the IP address (as a string) where the request came in. (This +corresponds to the environment variable <code>SERVER_ADDR</code> in +CGI scripts.) + +</blockquote> + + [Function] + <a class=none name="server-port">server-port <tt>&optional</tt> request => number</a> + +<blockquote> + +Returns the IP port (as a number) where the request came in. + +</blockquote> + + [Function] + <a class=none name="server-protocol">server-protocol <tt>&optional</tt> request => keyword</a> + +<blockquote> + +Returns the version of the http protocol which is used by the client as a Lisp keyword - this is usually either <code>:HTTP/1.0</code> or <code>:HTTP/1.1</code>. +(This corresponds to the environment +variable <code>SERVER_PROTOCOL</code> in CGI scripts.) + +</blockquote> + + [Function] + <a class=none name="mod-lisp-id">mod-lisp-id <tt>&optional</tt> request => string</a> + +<blockquote> + +Returns the 'Server ID' sent by mod_lisp. This corresponds to the +third parameter in the "<a +href='#LispServer'>LispServer</a>" directive in Apache's +configuration file and can be interesting if you deploy several different +Apaches or Hunchentoot instances at once. Returns <code>NIL</code> in stand-alone servers. + +</blockquote> + + [Function] + <a class=none name="ssl-session-id">ssl-session-id <tt>&optional</tt> request => string</a> + +<blockquote> + +Returns Apache's SSL session ID if it exists. Note that SSL sessions aren't related to <a href='#sessions'>Hunchentoot sessions</a>. +(This corresponds to +the environment variable <code>SSL_SESSION_ID</code> in CGI +scripts.) Returns <code>NIL</code> in stand-alone servers. + +</blockquote> + + [Function] + <a class=none name="user-agent">user-agent <tt>&optional</tt> request => string</a> + +<blockquote> + +Returns the value of the incoming <code>User-Agent</code> http header. +(This corresponds to +the environment variable <code>HTTP_USER_AGENT</code> in CGI +scripts.) + +</blockquote> + + [Function] + <a class=none name="referer">referer <tt>&optional</tt> request => string</a> + +<blockquote> + +Returns the value of the incoming <code>Referer</code> (sic!) http header. +(This corresponds to +the environment variable <code>HTTP_REFERER</code> in CGI +scripts.) + +</blockquote> + + [Function] + <a class=none name="cookie-in">cookie-in name <tt>&optional</tt> request => string</a> + +<blockquote> +Returns the value of the incoming cookie named by the string <code>name</code> (or <code>NIL</code> if there ain't no cookie with this name). See also <a href="#cookies-in"><code>COOKIES-IN</code></a>. +</blockquote> + + [Function] + <a class=none name="cookies-in">cookies-in <tt>&optional</tt> request => alist</a> + +<blockquote> +Returns an <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> of all incoming cookies. The <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#car">car</a> of each element of this list is the cookie's name while the <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#cdr">cdr</a> is the cookie's value. See also <a href="#cookie-in"><code>COOKIE-IN</code></a>. +</blockquote> + + [Accessor] + <a class=none name="aux-request-value">aux-request-value symbol <tt>&optional</tt> request => value, present-p + <tt>(setf (</tt>aux-request-value symbol <tt>&optional</tt> request) new-value<tt>)</tt></a> + +<blockquote> +This accessor can be used to associate arbitrary data with the the <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#symbol">symbol</a> <code>symbol</code> in the <code>REQUEST</code> +object <code>request</code>. +<code>present-p</code> is true if such data was found, +otherwise <code>NIL</code>. +</blockquote> + + [Function] + <a class=none name="delete-aux-request-value">delete-aux-request-value symbol <tt>&optional</tt> request => |</a> + +<blockquote> +Completely removes any data associated with the <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#symbol">symbol</a> <code>symbol</code> from the <code>REQUEST</code> +object <code>request</code>. Note that this is different from +using <a href="#aux-request-value"><code>AUX-REQUEST-VALUE</code></a> to set the data to <code>NIL</code>. +</blockquote> + + [Function] + <a class=none name="recompute-request-parameters">recompute-request-parameters <tt>&key</tt> request external-format => |</a> + +<blockquote> Recomputes the GET and POST parameters for +the <code>REQUEST</code> object +<code>request</code>. This only makes sense if you've changed +the external format and with POST parameters it will only work if the +request body was sent with +the <code>application/x-www-form-urlencoded</code> content type. + +The default value for +<code>external-format</code> is <a +href="#*hunchentoot-default-external-format*"><code>*HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*</code></a>. +See <code>test/test.lisp</code> for an example. +</blockquote> + +<h4><a class=none name="replies">Replies</a></h4> + +It is the responsibility of a <a href='#handlers'>handler</a> function to prepare the reply for the client. This is done by + +<ul> + <li>returning a string or an array of octets which will be the reply's body and + <li>manipulating a <code>REPLY</code> object which will be described in this section. +</ul> + +For each request there's one <code>REPLY</code> object which is accessible +to the handler via the +special variable <a href='#*reply*'>*REPLY*</a>. This object holds +all the information available about the reply and can be accessed +with the functions described in this chapter. Note that the internal +structure of <code>REPLY</code> objects should be considered opaque and may change +in future releases of Hunchentoot. + +In all of the functions below, the default value +for the optional argument <code>reply</code> is the value of <a href='#*reply*'>*REPLY*</a>, +i.e. handlers will usually not need to provide this argument when +calling the function. + +While Hunchentoot's preferred way of sending data to the client is the +one described above (i.e. the handler returns the whole payload as a +string or an array of octets) you can, if you really need to (for +example for large content bodies), get a stream you can write to +directly. This is achieved by first setting +up <a href="#*reply*"><code>*REPLY*</code></a> and then +calling <a href="#send-headers"><code>SEND-HEADERS</code></a>. Note +that in this case the usual <a href="#log">error handling</a> is +disabled. See the file <code>test/test.lisp</code> for an example. + + [Special variable] + <a class=none name="*reply*">*reply*</a> + +<blockquote> + +Holds the current <code>REPLY</code> object. + +</blockquote> + + [Accessor] + <a class=none name="header-out">header-out name <tt>&optional</tt> reply => string + <tt>(setf (</tt>header-out name <tt>&optional</tt> reply) new-value<tt>)</tt></a> + +<blockquote> + +<code>HEADER-OUT</code> returns the outgoing http header named by the +keyword <code>name</code> if there is one, +otherwise <code>NIL</code>. <code>SETF</code> +of <code>HEADER-OUT</code> changes the current value of the header +named <code>name</code>. If no header +named <code>name</code> exists it is created. For backwards +compatibility, <code>name</code> can also be a string in which +case the association between a header and its name is +case-insensitive. + +Note that the +headers <code>Set-Cookie</code>, <code>Content-Length</code>, +and <code>Content-Type</code> cannot be queried +by <code>HEADER-OUT</code> and must not be set +by <code>SETF</code> of <code>HEADER-OUT</code>. Also, there are a +couple of "technical" headers like <code>Connection</code> +or <code>Transfer-Encoding</code> that you're not supposed to set +yourself. If in doubt, consult the source code or ask on +the <a href="#mail">mailing list</a>. + +See also <a href="#headers-out"><code>HEADERS-OUT</code></a>, <a href="#content-type"><code>CONTENT-TYPE</code></a>, <a href="#content-length"><code>CONTENT-LENGTH</code></a>, <a href="#cookies-out"><code>COOKIES-OUT</code></a>, and <a href="#cookie-out"><code>COOKIE-OUT</code></a>. + +</blockquote> + + [Function] + <a class=none name="headers-out">headers-out <tt>&optional</tt> request => alist</a> + +<blockquote> +Returns an <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> of all outgoing http parameters (except for <code>Set-Cookie</code>, <code>Content-Length</code>, +and <code>Content-Type</code>). The <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#car">car</a> of each element of this list is the headers's name while the <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#cdr">cdr</a> is its value. This alist should not be manipulated directly, use <code>SETF</code> of <a href="#header-out"><code>HEADER-OUT</code></a> instead. +</blockquote> + + [Function] + <a class=none name="cookie-out">cookie-out name <tt>&optional</tt> reply => cookie</a> + +<blockquote> +Returns the outgoing cookie named by the string <code>name</code> (or <code>NIL</code> if there ain't no cookie with this name). See also <a href="#cookies-out"><code>COOKIES-OUT</code></a> and <a href='#cookies'>the section about cookies</a>. +</blockquote> + + [Function] + <a class=none name="cookies-out">cookies-out <tt>&optional</tt> reply => alist</a> + +<blockquote> +Returns an <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> of all outgoing cookies. The <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#car">car</a> of each element of this list is the cookie's name while the <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#cdr">cdr</a> is the cookie itself. See also <a href="#cookie-out"><code>COOKIE-OUT</code></a> and <a href='#cookies'>the section about cookies</a>. +</blockquote> + + [Accessor] + <a class=none name="return-code">return-code <tt>&optional</tt> reply => number + <tt>(setf (</tt>return-code <tt>&optional</tt> reply) new-value<tt>)</tt></a> + +<blockquote> + +<code>RETURN-CODE</code> returns the http return code of the +reply, <code>SETF</code> of <code>RETURN-CODE</code> changes it. The +return code of each <code>REPLY</code> object is initially set to <a +href="#+http-ok+"><code>+HTTP-OK+</code></a>. + +</blockquote> + + [Accessor] + <a class=none name="content-type">content-type <tt>&optional</tt> reply => string + <tt>(setf (</tt>content-type <tt>&optional</tt> reply) new-value<tt>)</tt></a> + +<blockquote> + +<code>CONTENT-TYPE</code> returns the +outgoing <code>Content-Type</code> http header. <code>SETF</code> +of <code>CONTENT-TYPE</code> changes the current value of this header. The content type of each <code>REPLY</code> object is initially set to the value of <a href="#*default-content-type*"><code>*DEFAULT-CONTENT-TYPE*</code></a>. +</blockquote> + + [Accessor] + <a class=none name="content-length">content-length <tt>&optional</tt> reply => length + <tt>(setf (</tt>content-length <tt>&optional</tt> reply) new-value<tt>)</tt></a> + +<blockquote> + +<code>CONTENT-LENGTH</code> returns the outgoing +<code>Content-Length</code> http header. <code>SETF</code> of +<code>CONTENT-LENGTH</code> changes the current value of this +header. The content length of each <code>REPLY</code> object is +initially set to <code>NIL</code>. If you leave it like that, +Hunchentoot will automatically try to compute the correct value +using <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/f_length.htm"><code>LENGTH</code></a>. +If you set the value yourself, you must make sure that it's +the correct length of the body in octets (not in characters). +In this case, Hunchentoot will use the value as is which can lead to +erroneous behaviour if it is wrong - so, use at your own risk. + +Note that setting this value explicitly doesn't mix well with <a +href="#*rewrite-for-session-urls*">URL rewriting</a>. + +</blockquote> + + [Function] + <a class=none name="send-headers">send-headers => stream</a> + +<blockquote> +Sends the initial status line and all headers as determined by +the <code>REPLY</code> object <a href="#*reply*"><code>*REPLY*</code></a>. Returns a <a href="http://weitz.de/flexi-streams/#flexi-streams">flexi stream</a> to which the body of +the reply can be written. Once this function has been called, +further changes to <a href="#*reply*"><code>*REPLY*</code></a> don't have any effect. Also, +<a href="#log">automatic handling of errors</a> (i.e. sending the +corresponding status code to the browser, etc.) is turned off for this +request. Likewise, functions +like <a href="#redirect"><code>REDIRECT</code></a> or throwing +to <a href="#handler-done"><code>HANDLER-DONE</code></a> +won't have the desired effect once the headers are sent. + +If your handlers return the full body as a string or as an array of +octets, you should not call this function. If a handler +calls <a href="#send-headers"><code>SEND-HEADERS</code></a>, its return +value is ignored. + +See also <a href="#reply-external-format"><code>REPLY-EXTERNAL-FORMAT</code></a>. +</blockquote> + + [Accessor] + <a class=none name="reply-external-format">reply-external-format <tt>&optional</tt> reply => external-format + <tt>(setf (</tt>reply-external-format <tt>&optional</tt> reply) new-value<tt>)</tt></a> + +<blockquote> + +Gets and sets the external format of the <code>REPLY</code> +object <code>reply</code>. This external format is used when +character content is written to the client after the headers have been +sent. In particular, it is the external format of the stream returned by <a href="#send-headers"><code>SEND-HEADERS</code></a> (but of course you can change it because it's a <a href="http://weitz.de/flexi-streams/#flexi-streams">flexi stream</a>). +The initial value for each request is the value +of <a +href="#*hunchentoot-default-external-format*"><code>*HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*</code></a>. + +</blockquote> + + [Constants] + <a class=none name='+http-continue+'>+http-continue+</a> + <a class=none name='+http-switching-protocols+'>+http-switching-protocols+</a> + <a class=none name='+http-ok+'>+http-ok+</a> + <a class=none name='+http-created+'>+http-created+</a> + <a class=none name='+http-accepted+'>+http-accepted+</a> + <a class=none name='+http-non-authoritative-information+'>+http-non-authoritative-information+</a> + <a class=none name='+http-no-content+'>+http-no-content+</a> + <a class=none name='+http-reset-content+'>+http-reset-content+</a> + <a class=none name='+http-partial-content+'>+http-partial-content+</a> + <a class=none name='+http-multi-status+'>+http-multi-status+</a> + <a class=none name='+http-multiple-choices+'>+http-multiple-choices+</a> + <a class=none name='+http-moved-permanently+'>+http-moved-permanently+</a> + <a class=none name='+http-moved-temporarily+'>+http-moved-temporarily+</a> + <a class=none name='+http-see-other+'>+http-see-other+</a> + <a class=none name='+http-not-modified+'>+http-not-modified+</a> + <a class=none name='+http-use-proxy+'>+http-use-proxy+</a> + <a class=none name='+http-temporary-redirect+'>+http-temporary-redirect+</a> + <a class=none name='+http-bad-request+'>+http-bad-request+</a> + <a class=none name='+http-authorization-required+'>+http-authorization-required+</a> + <a class=none name='+http-payment-required+'>+http-payment-required+</a> + <a class=none name='+http-forbidden+'>+http-forbidden+</a> + <a class=none name='+http-not-found+'>+http-not-found+</a> + <a class=none name='+http-method-not-allowed+'>+http-method-not-allowed+</a> + <a class=none name='+http-not-acceptable+'>+http-not-acceptable+</a> + <a class=none name='+http-proxy-authentication-required+'>+http-proxy-authentication-required+</a> + <a class=none name='+http-request-time-out+'>+http-request-time-out+</a> + <a class=none name='+http-conflict+'>+http-conflict+</a> + <a class=none name='+http-gone+'>+http-gone+</a> + <a class=none name='+http-length-required+'>+http-length-required+</a> + <a class=none name='+http-precondition-failed+'>+http-precondition-failed+</a> + <a class=none name='+http-request-entity-too-large+'>+http-request-entity-too-large+</a> + <a class=none name='+http-request-uri-too-large+'>+http-request-uri-too-large+</a> + <a class=none name='+http-unsupported-media-type+'>+http-unsupported-media-type+</a> + <a class=none name='+http-requested-range-not-satisfiable+'>+http-requested-range-not-satisfiable+</a> + <a class=none name='+http-expectation-failed+'>+http-expectation-failed+</a> + <a class=none name='+http-failed-dependency+'>+http-failed-dependency+</a> + <a class=none name='+http-internal-server-error+'>+http-internal-server-error+</a> + <a class=none name='+http-not-implemented+'>+http-not-implemented+</a> + <a class=none name='+http-bad-gateway+'>+http-bad-gateway+</a> + <a class=none name='+http-service-unavailable+'>+http-service-unavailable+</a> + <a class=none name='+http-gateway-time-out+'>+http-gateway-time-out+</a> + <a class=none name='+http-version-not-supported+'>+http-version-not-supported+</a> + +<blockquote> +The values of these constants are 100, 101, 200, 201, 202, 203, 204, 205, 206, 207, 300, 301, 302, 303, 304, 305, 307, 400, 401, 402, 403, 404, 405, 406, 407, 408, 409, 410, 411, 412, 413, 414, 415, 416, 417, 424, 500, 501, 502, 503, 504, and 505. See <a href="#return-code"><code>RETURN-CODE</code></a>. +</blockquote> + + [Special variable] + <a class=none name='*default-content-type*'>*default-content-type*</a> + +<blockquote> +The value of this variable is used to initialize the content type of each <code>REPLY</code> object. Its initial value is <code>"text/html; charset=iso-8859-1"</code>. See <a href="#content-type"><code>CONTENT-TYPE</code></a>. +</blockquote> + +<h4><a class=none name="cookies">Cookies</a></h4> + +Outgoing cookies are stored in the request's <code>REPLY</code> object (see <a href="#cookie-out"><code>COOKIE-OUT</code></a> and <a href="#cookies-out"><code>COOKIES-OUT</code></a>). They are CLOS objects defined like this: + +<pre> +(defclass cookie () + ((name :initarg :name + :reader <a class=noborder name='cookie-name'>cookie-name</a> + :type string + :documentation "The name of the cookie - a string.") + (value :initarg :value + :accessor <a class=noborder name='cookie-value'>cookie-value</a> + :initform "" + :documentation "The value of the cookie. Will be URL-encoded when sent to the browser.") + (expires :initarg :expires + :initform nil + :accessor <a class=noborder name='cookie-expires'>cookie-expires</a> + :documentation "The time (a universal time) when the cookie expires (or NIL).") + (path :initarg :path + :initform nil + :accessor <a class=noborder name='cookie-path'>cookie-path</a> + :documentation "The path this cookie is valid for (or NIL).") + (domain :initarg :domain + :initform nil + :accessor <a class=noborder name='cookie-domain'>cookie-domain</a> + :documentation "The domain this cookie is valid for (or NIL).") + (secure :initarg :secure + :initform nil + :accessor <a class=noborder name='cookie-secure'>cookie-secure</a> + :documentation "A generalized boolean denoting whether this is a secure cookie.") + (http-only :initarg :http-only + :initform nil + :accessor <a class=noborder name='cookie-http-only'>cookie-http-only</a> + :documentation "A generalized boolean denoting whether this is a <a href="http://msdn2.microsoft.com/en-us/library/ms533046.aspx">HttpOnly</a> cookie."))) +</pre> + +The <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_r.htm#reader">reader</a> <a href="#cookie-name"><code>COOKIE-NAME</code></a> and +the <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#accessor">accessors</a> +<a href="#cookie-value"><code>COOKIE-VALUE</code></a>, <a +href="#cookie-expires"><code>COOKIE-EXPIRES</code></a>, <a +href="#cookie-path"><code>COOKIE-PATH</code></a>, <a +href="#cookie-domain"><code>COOKIE-DOMAIN</code></a>, <a +href="#cookie-secure"><code>COOKIE-SECURE</code></a>, and <a +href="#cookie-http-only"><code>COOKIE-HTTP-ONLY</code></a> are all exported +from the <code>HUNCHENTOOT</code> package. + + [Function] + <a class=none name="set-cookie">set-cookie name <tt>&key</tt> value expires path domain secure http-only reply => cookie</a> + +<blockquote> Creates a <code>COOKIE</code> object from the +parameters provided to this function and adds it to the outgoing +cookies of the <a href='#replies'><code>REPLY</code> +object</a> <code>reply</code>. If a cookie with the same name +(case-sensitive) already exists, it is replaced. The default +for <code>reply</code> is <a +href="#*reply*"><code>*REPLY*</code></a>. The default for <code>value</code> is the empty string. +</blockquote> + + [Function] + <a class=none name="set-cookie*">set-cookie* cookie <tt>&optional</tt> reply => cookie</a> + +<blockquote> Adds the <code>COOKIE</code> +object <code>cookie</code> to the outgoing cookies of the <a +href='#replies'><code>REPLY</code> +object</a> <code>reply</code>. If a cookie with the same name +(case-sensitive) already exists, it is replaced. The default for <code>reply</code> is <a href="#*reply*"><code>*REPLY*</code></a>. +</blockquote> + +<h4><a class=none name="sessions">Sessions</a></h4> + +Hunchentoot supports sessions: Once a Hunchentoot page has +called <a href="#start-session"><code>START-SESSION</code></a>, +Hunchentoot uses either cookies or (if the client doesn't send the +cookies back) <a href="#*rewrite-for-session-urls*">rewrites URLs</a> +to keep track of this client, i.e. to provide a kind of 'state' for +the stateless http protocol. The session associated with the client is +an opaque CLOS object which can be used to store arbitrary data +between requests. + +Hunchentoot makes some reasonable effort to prevent eavesdroppers from +hijacking sessions (see below), but this should not be considered +really secure. Don't store sensitive data in sessions and rely +solely on the session mechanism as a safeguard against malicious users +who want to get at this data! + +For each request there's one <code>SESSION</code> object which is accessible +to the handler via the +special variable <a href='#*session*'><code>*SESSION*</code></a>. This object holds +all the information available about the session and can be accessed +with the functions described in this chapter. Note that the internal +structure of <code>SESSION</code> objects should be considered opaque and may change +in future releases of Hunchentoot. + +Sessions are automatically verified for validity and age when +the <a href='#requests'><code>REQUEST</code> object</a> is instantiated, i.e. if <a +href='#*session*'><code>*SESSION*</code></a> is not <code>NIL</code> then this +session is valid (as far as Hunchentoot is concerned) and not too old. Old sessions are <a href="#session-gc">automatically removed</a>. + + [Special variable] + <a class=none name="*session*">*session*</a> + +<blockquote> + +Holds the current <code>SESSION</code> object (if any) or <code>NIL</code>. + +</blockquote> + + [Function] + <a class=none name="start-session">start-session => session</a> + +<blockquote> Returns <a +href="#*session*"><code>*SESSION*</code></a> if it +isn't <code>NIL</code>, otherwise creates a new <code>SESSION</code> +object and returns it. +</blockquote> + + [Accessor] + <a class=none name="session-value">session-value symbol <tt>&optional</tt> session => value, present-p + <tt>(setf (</tt>session-value symbol <tt>&optional</tt> session) new-value<tt>)</tt></a> + +<blockquote> +This accessor can be used to associate arbitrary data with the the <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#symbol">symbol</a> <code>symbol</code> in the <code>SESSION</code> +object <code>session</code>. +<code>present-p</code> is true if such data was found, +otherwise <code>NIL</code>. The default value +for <code>session</code> is <a +href="#*session*"><code>*SESSION*</code></a>. + +If <code>SETF</code> of <code>SESSION-VALUE</code> is called with <code>session</code> being <code>NIL</code> then a session is automatically instantiated with <a href="#start-session"><code>START-SESSION</code></a>. +</blockquote> + + [Function] + <a class=none name="delete-session-value">delete-session-value symbol <tt>&optional</tt> session => |</a> + +<blockquote> +Completely removes any data associated with the <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#symbol">symbol</a> <code>symbol</code> from the <code>SESSION</code> +object <code>session</code>. Note that this is different from +using <a href="#session-value"><code>SESSION-VALUE</code></a> to set the data to <code>NIL</code>. +The default value +for <code>session</code> is <a +href="#*session*"><code>*SESSION*</code></a>. +</blockquote> + + + [Function] + <a class=none name="remove-session">remove-session session => |</a> + +<blockquote> +Completely removes the session <code>session</code> from Hunchentoot's internal session database. See also <a href="#*session-removal-hook*"><code>*SESSION-REMOVAL-HOOK*</code></a>. +</blockquote> + + + [Function] + <a class=none name="reset-sessions">reset-sessions => |</a> + +<blockquote> +This function unconditionally invalidates and destroys all sessions immediately. +</blockquote> + + + [Function] + <a class=none name="session-cookie-value">session-cookie-value session => string</a> + +<blockquote> +Returns a unique string that's associated with +the <code>SESSION</code> object <code>session</code>. This +string is sent to the browser as a cookie value or as a GET parameter, +</blockquote> + + + [Function] + <a class=none name="session-counter">session-counter session => count</a> + +<blockquote> +Returns the number of times (requests) the <code>SESSION</code> object <code>session</code> has been used. +</blockquote> + + + + [Accessor] + <a class=none name="session-max-time">session-max-time session => seconds + <tt>(setf (</tt>session-max-time session) seconds<tt>)</tt></a> + +<blockquote> This gets or sets the maximum time (in seconds) +the <code>SESSION</code> object <code>session</code> should be +valid before it's invalidated: If a request associated with this +session comes in and the last request for the same session was more +than <code>seconds</code> seconds ago +than the session is deleted and a new one is started for this client. The default value is determined by <a href="#*session-max-time*"><code>*SESSION-MAX-TIME*</code></a>. +</blockquote> + + [Function] + <a class=none name="session-remote-addr">session-remote-addr session => address</a> + +<blockquote> Returns the 'real' remote address (see <a +href="#real-remote-addr"><code>REAL-REMOTE-ADDR</code></a>) of the +client for which the <code>SESSION</code> +object <code>session</code> was initiated. +</blockquote> + + [Function] + <a class=none name="session-user-agent">session-user-agent session => address</a> + +<blockquote> Returns the 'User-Agent' http header (see <a +href="#user-agent"><code>USER-AGENT</code></a>) of the +client for which the <code>SESSION</code> +object <code>session</code> was initiated. +</blockquote> + + [Special variable] + <a class=none name="*use-remote-addr-for-sessions*">*use-remote-addr-for-sessions*</a> + +<blockquote> + +If this value is true (the default is <code>NIL</code>) then +the 'real' remote address (see <a +href="#real-remote-addr"><code>REAL-REMOTE-ADDR</code></a>) of the +client will be encoded into the session identifier, i.e. if this value +changes on the client side, the session will automatically be +invalidated. + +Note that this is not secure, because it's obviously not very hard to +fake an <code>X_FORWARDED_FOR</code> header. On the other hand, +relying on the remote address (see <a +href="#remote-addr"><code>REMOTE-ADDR</code></a>) of the client isn't +an ideal solution either, because some of your users may connect +through http proxies and the proxy they use may change during the +session. But then again, some proxies don't +send <code>X_FORWARDED_FOR</code> headers anyway. Sigh... + +</blockquote> + + [Special variable] + <a class=none name="*use-user-agent-for-sessions*">*use-user-agent-for-sessions*</a> + +<blockquote> If this value is true (which is the default) +then the 'User-Agent' http header (see <a +href="#user-agent"><code>USER-AGENT</code></a>) of the client will be +encoded into the session identifier, i.e. if this value changes on the +client side the session will automatically be invalidated. + +While this is intended to make the life of malicious users harder, it +might affect legitimate users as well: I've seen this http +header change with certain browsers when the Java plug-in was used. +</blockquote> + + [Special variable] + <a class=none name="*rewrite-for-session-urls*">*rewrite-for-session-urls*</a> + +<blockquote> If this value is true (which is the default) +then content bodies sent by Hunchentoot will be rewritten +(using <a href='http://weitz.de/url-rewrite/'>URL-REWRITE</a>) such +that GET parameters for session handling are appended to all relevant +URLs. This only happens, though, if the body's content type (see <a +href="#content-type"><code>CONTENT-TYPE</code></a>) starts +with one of the strings in <a href="#*content-types-for-url-rewrite*"><code>*CONTENT-TYPES-FOR-URL-REWRITE*</code></a> and unless the client has already sent a cookie named <a href="#*session-cookie-name*"><code>*SESSION-COOKIE-NAME*</code></a>. + +Note that the function which rewrites the body doesn't understand +Javascript, so you have to take care of URLs in Javascript code yourself. +</blockquote> + + [Special variable] + <a class=none name="*content-types-for-url-rewrite*">*content-types-for-url-rewrite*</a> + +<blockquote> +This is a list of strings (the initial value is +<code>("text/html" "application/xhtml+xml")</code>) the +content-type of an outgoing body is compared with if <a +href="#*rewrite-for-session-urls*"><code>*REWRITE-FOR-SESSION-URLS*</code></a> +is true. If the content-type starts with one of these strings, then +url-rewriting will happen, otherwise it won't. +</blockquote> + + [Special variable] + <a class=none name="*session-cookie-name*">*session-cookie-name*</a> + +<blockquote> + +This is the name that is used for the session-related cookie or GET +parameter sent to the client. Its default value +is <code>"hunchentoot-session"</code>. Note that changing this name while +Hunchentoot is running will invalidate existing sessions. + +</blockquote> + + [Special variable] + <a class=none name="*session-removal-hook*">*session-removal-hook*</a> + +<blockquote> +The value of this variable should be a function of one argument, a <code>SESSION</code> object. This function is called directly before the session is destroyed, either by <a href="#reset-sessions"><code>RESET-SESSIONS</code></a>, by <a href="#remove-session"><code>REMOVE-SESSION</code></a>, or when it's invalidated because it's too old. + +</blockquote> + + [Special variable] + <a class=none name="*session-max-time*">*session-max-time*</a> + +<blockquote> +The default time (in seconds) after which a session times out - see <a href="#session-max-time"><code>SESSION-MAX-TIME</code></a>. This value is initially set to 1800. +</blockquote> + + [Macro] + <a class=none name="do-sessions">do-sessions (var <tt>&optional</tt> result-form) statement* => result</a> + +<blockquote> + +Executes the statements with <code>var</code> bound to each +existing <code>SESSION</code> object consecutively. An implicit block +named <code>NIL</code> surrounds the body of this macro. Returns the +values returned by <code>result-form</code> unless +<code>RETURN</code> is executed. The scope of the binding of +<code>var</code> does not include +<code>result-form</code>. + +</blockquote> + + [Special variable] + <a class=none name="*session-gc-frequency*">*session-gc-frequency*</a> + +<blockquote> +A session garbage collection (see <a href="#session-gc"><code>SESSION-GC</code></a>) will happen every +<a +href="#*session-gc-frequency*"><code>*SESSION-GC-FREQUENCY*</code></a> +requests (counting only requests which use sessions) if the value of +this variable is not <code>NIL</code>. It's default value is 50. +</blockquote> + + [Function] + <a class=none name="session-gc">session-gc => |</a> + +<blockquote> +Deletes sessions which are too old - see +<a href="#session-too-old-p"><code>SESSION-TOO-OLD-P</code></a>. +Usually, you don't call this function directly - +see <a +href="#*session-gc-frequency*"><code>*SESSION-GC-FREQUENCY*</code></a>. +</blockquote> + + [Function] + <a class=none name="session-too-old-p">session-too-old-p session => generalized-boolean</a> + +<blockquote> Returns a true value if the <code>SESSION</code> +object <code>session</code> is <a href="#session-max-time">too old</a> and would be deleted +during the next <a href="#session-gc">session GC</a>. You don't +have to check this manually for sessions +in <a href="#*session*"><code>*SESSION*</code></a>, but it might be +useful if you want to <a href="#do-sessions">loop through all +sessions</a>. +</blockquote> + + +<h4><a class=none name="log">Logging and error handling</a></h4> + +Hunchentoot provides facilities for writing to Apache's error log +file (when using the mod_lisp front-end) or for logging to an arbitrary file in the file system. Note that, due to the nature of mod_lisp, Apache log mesages don't appear immediately but only after all data has been sent from Hunchentoot to Apache/mod_lisp. + +Furthermore, all errors happening within a <a href='#handlers'>handler</a> which are not +caught by the handler itself are handled by Hunchentoot - see details below. + + [Accessor] + <a class=none name="log-file">log-file => pathname + <tt>(setf (</tt>log-file) pathspec<tt>)</tt></a> + +<blockquote> +The function <code>LOG-FILE</code> returns a pathname designating the log file which is currently used (unless log messages are forwarded to Apache). This destination for log messages can be changed with <code>(SETF LOG-FILE)</code>. The initial location of the log file is implementation-dependent. +</blockquote> + + [Generic function] + <a class=none name="log-message">log-message log-level format <tt>&rest</tt> args => |</a> + +<blockquote> Schedules a message for the Apache log file or writes +it directly to <a href="#log-file">the current log file</a> depending +on the value of the <code>use-apache-log-p</code> argument +to <a href="#start-server"><code>START-SERVER</code></a>. <code>log-level</code> +should be one of the +keywords <code>:EMERG</code>, <code>:ALERT</code>, <code>:CRIT</code>, <code>:ERROR</code>, <code>:WARNING</code>, <code>:NOTICE</code>, <code>:INFO</code>, +or <code>:DEBUG</code> which correspond to the various Apache log +levels. <code>log-level</code> can also be <code>NIL</code> (in +which case mod_lisp's default log level is used. If Apache isn't used, the log level is just written +to the log file unless it's <code>NIL</code>. +<code>format</code> and <code>args</code> are used as with +<a href='http://www.lispworks.com/documentation/HyperSpec/Body/f_format.htm'><code>FORMAT</code></a>. + +<code>LOG-MESSAGE</code> is a generic function, so you can specialize it or bypass it completely with an around method. +</blockquote> + + [Function] + <a class=none name="log-message*">log-message* format <tt>&rest</tt> args => |</a> + +<blockquote> +Like <a href="#log-message"><code>LOG-MESSAGE</code></a> but with <code>log-level</code> set to <a href="#*default-log-level*"><code>*DEFAULT-LOG-LEVEL*</code></a>. +</blockquote> + + [Special variable] + <a class=none name="*default-log-level*">*default-log-level*</a> + +<blockquote> +The log level used by <a href="#log-message*"><code>LOG-MESSAGE*</code></a>. The initial value is <code>NIL</code>. +</blockquote> + + [Special variable] + <a class=none name="*log-lisp-errors-p*">*log-lisp-errors-p*</a> + +<blockquote> +Whether unhandled errors in <a href='#handlers'>handlers</a> should be logged. See also <a href="#*lisp-errors-log-level*"><code>*LISP-ERRORS-LOG-LEVEL*</code></a>. The default value is <code>T</code>. +</blockquote> + + [Special variable] + <a class=none name="*lisp-errors-log-level*">*lisp-errors-log-level*</a> + +<blockquote> +The log level used to log Lisp errors. See also <a href="#*log-lisp-errors-p*"><code>*LOG-LISP-ERRORS-P*</code></a>. The default value is <code>:ERROR</code>. +</blockquote> + + [Special variable] + <a class=none name="*log-lisp-warnings-p*">*log-lisp-warnings-p*</a> + +<blockquote> +Whether unhandled warnings in <a href='#handlers'>handlers</a> should be logged. See also <a href="#*lisp-warnings-log-level*"><code>*LISP-WARNINGS-LOG-LEVEL*</code></a>. The default value is <code>T</code>. +</blockquote> + + [Special variable] + <a class=none name="*lisp-warnings-log-level*">*lisp-warnings-log-level*</a> + +<blockquote> +The log level used to log Lisp warnings. See also <a href="#*log-lisp-warnings-p*"><code>*LOG-LISP-WARNINGS-P*</code></a>. The default value is <code>:WARNING</code>. +</blockquote> + + [Special variable] + <a class=none name="*log-lisp-backtraces-p*">*log-lisp-backtraces-p*</a> + +<blockquote> +Whether backtraces should also be logged in addition to error messages and warnings. This value will only have effect if <a href="#*log-lisp-errors-p*"><code>*LOG-LISP-ERRORS-P*</code></a> or <a href="#*log-lisp-warnings-p*"><code>*LOG-LISP-WARNINGS-P*</code></a> is true. The default value is <code>NIL</code>. +</blockquote> + + [Special variable] + <a class=none name="*log-prefix*">*log-prefix*</a> + +<blockquote> +All messages written to the Apache error log by Hunchentoot are prepended by a string which is the value of this variable enclosed in square brackets. If the value is <code>NIL</code>, however, no such prefix will be written. If the value is <code>T</code> (which is the default), the prefix will be <code>"[Hunchentoot]"</code>. +</blockquote> + + [Special variable] + <a class=none name="*show-lisp-errors-p*">*show-lisp-errors-p*</a> + +<blockquote> +Whether unhandled Lisp errors should be shown to the user. If this value is <code>NIL</code> (which is the default), only the message An error has occurred will be shown. +</blockquote> + + [Special variable] + <a class=none name="*show-lisp-backtraces-p*">*show-lisp-backtraces-p*</a> + +<blockquote> +Whether backtraces should also be shown to the user. This value will only have effect if <a href="#*show-lisp-errors-p*"><code>*SHOW-LISP-ERRORS-P*</code></a> is true. The default value is <code>NIL</code>. +</blockquote> + + [Special variable] + <a class=none name="*show-access-log-messages*">*show-access-log-messages*</a> + +<blockquote> +If this variable is true and if the value of the <code>use-apache-log-p</code> argument to <a href="#start-server"><code>START-SERVER</code></a> was <code>NIL</code>, then for each request a line somewhat similar to what can be found in Apache's access log will be written to the <a href="#log-file">log file</a>. The default value of this variable is <code>T</code>. +</blockquote> + + [Special variable] + <a class=none +name="*http-error-handler*">*http-error-handler*</a> + +<blockquote> +This variable holds <code>NIL</code> (the default) or a <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function…">function designator</a> for a function of one argument. The function gets called if the responsible <a href="#handlers">handler</a> has set a return code which is not in <a href="#*approved-return-codes*"><code>*APPROVED-RETURN-CODES*</code></a> and <a href="#*handle-http-errors-p*"><code>*HANDLE-HTTP-ERRORS-P*</code></a> is true. It receives the return code as its argument and can return the contents of an error page or <code>NIL</code> if it refuses to handle the error, i.e. if Hunchentoot's default error page should be shown. (Note that the function can access the request and reply data.) +</blockquote> + + [Special variable] + <a class=none +name="*handle-http-errors-p*">*handle-http-errors-p*</a> + +<blockquote> This variable holds a generalized boolean that +determines whether return codes not in <a href="#*approved-return-codes*"><code>*APPROVED-RETURN-CODES*</code></a> +are treated specially. When its value is true (the default), either a +default body for the return code or the result of +calling <a +href="#*http-error-handler*"><code>*HTTP-ERROR-HANDLER*</code></a> is +used. When the value is <code>NIL</code>, no special action is taken +and you are expected to supply your own response body to describe the +error. +</blockquote> + + [Special variable] + <a class=none +name="*approved-return-codes*">*approved-return-codes*</a> +<blockquote> +A list of return codes the server should not treat as an error - +see <a href="#*handle-http-errors-p*"><code>*HANDLE-HTTP-ERRORS-P*</code></a>. The initial value is the list with the values of +<a href="#+http-ok+"><code>+HTTP-OK+</code></a>, <a href="#+http-no-content+"><code>+HTTP-NO-CONTENT+</code></a>, <a href="#+http-multi-status+"><code>+HTTP-MULTI-STATUS+</code></a>, and <a href="#+http-not-modified+"><code>+HTTP-NOT-MODIFIED+</code></a>. +</blockquote> + + [Function] + <a class=none name="get-backtrace">get-backtrace condition => backtrace</a> + +<blockquote> +This is the function that is used internally by Hunchentoot to +show or log backtraces. It accepts a condition object <code>condition</code> and +returns a string with the corresponding backtrace. +</blockquote> + +<h4><a class=none name="debug">Debugging Hunchentoot applications</a></h4> + +The best option to debug a Hunchentoot application is +probably <a href="#*catch-errors-p*">to use the debugger</a>. + +One important thing you should try if you're behind mod_lisp is to +use <a href="#log">an external log file</a> (as opposed to Apache's +log) because it can reveal error messages that might otherwise get +lost if something's broken in the communication between Hunchentoot +and mod_lisp. + +Good luck... :) + + [Special variable] + <a class=none name="*catch-errors-p*">*catch-errors-p*</a> + +<blockquote> If the value of this variable is <code>NIL</code> +(the default is <code>T</code>), then errors which happen while a +request is handled aren't <a href="#log">caught as usual</a>, but +instead your +Lisp's <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_d.htm#debugger">debugger</a> +is <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/f_invoke.htm">invoked</a>. +This variable should obviously always be set to a true value +in a production environment. +See <a +href="#maybe-invoke-debugger"><code>MAYBE-INVOKE-DEBUGGER</code></a> +if you want to fine-tune this behaviour. +</blockquote> + + [Generic function] + <a class=none name="maybe-invoke-debugger">maybe-invoke-debugger condition => |</a> + +<blockquote> +This generic function is called whenever a +<a +href="http://www.lispworks.com/documentation/HyperSpec/Body/09_.htm">condition</a> <code>condition</code> +is signaled in Hunchentoot. You might want to specialize it on +specific condition classes for debugging purposes. The default +method <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/f_invoke.htm">invokes +the debugger</a> with <code>condition</code> if +<a href="#*catch-errors-p*"><code>*CATCH-ERRORS-P*</code></a> is <code>NIL</code>. +</blockquote> + + + [Special variable] + <a class=none name="*header-stream*">*header-stream*</a> + +<blockquote> +If this variable is not <code>NIL</code>, it should be bound to a stream to +which incoming and outgoing headers will be written for debugging +purposes. +</blockquote> + +<h4><a class=none name="misc">Miscellaneous</a></h4> + +Various functions and variables which didn't fit into one of the other categories. + + [Function] + <a class=none name="ssl-p">ssl-p => generalized-boolean</a> + +<blockquote> +Whether the current connection to the client is secure. +</blockquote> + + [Symbol] + <a class=none name="handler-done">handler-done</a> + +<blockquote> This is a <a +href='http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#catch_tag'>catch +tag</a> which names a <a +href='http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#catch'>catch</a> +which is active during the lifetime of a <a +href='#handlers'>handler</a>. The handler can at any time <a +href='http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#throw'>throw</a> +the outgoing content body (or <code>NIL</code>) to this catch to immediately abort handling the request. See the source code of <a href="#redirect"><code>REDIRECT</code></a> for an example. +</blockquote> + + [Function] + <a class=none name="no-cache">no-cache => |</a> + +<blockquote> +This function will set appropriate outgoing headers to completely prevent caching on virtually all browsers. +</blockquote> + + [Function] + <a class=none name="handle-if-modified-since">handle-if-modified-since time => |</a> + +<blockquote> + +This function is designed to be used inside a <a +href='#handlers'>handler</a>. If the client has sent an +'If-Modified-Since' header (see <a +href='http://www.faqs.org/rfcs/rfc2616.html'>RFC 2616</a>, +section 14.25) and the time specified matches the universal time +<code>time</code> then the header <a +href="#+http-not-modified+"><code>+HTTP-NOT-MODIFIED+</code></a> with +no content is immediately returned to the client. + +Note that for this function to be useful you should usually send +'Last-Modified' headers back to the client. See the code of <a +href="#create-static-file-dispatcher-and-handler"><code>CREATE-STATIC-FILE-DISPATCHER-AND-HANDLER</code></a> +for an example. + +</blockquote> + + [Function] + <a class=none name="rfc-1123-date">rfc-1123-date <tt>&optional</tt> time => string</a> + +<blockquote> + +This function accepts a universal time <code>time</code> +(default is the current time) and returns a string which encodes this time according to <a +href='http://www.faqs.org/rfcs/rfc1123.html'>RFC 1123</a>. This can be used to send a 'Last-Modified' header - see <a +href="#handle-if-modified-since"><code>HANDLE-IF-MODIFIED-SINCE</code></a>. + +</blockquote> + + [Function] + <a class=none name="redirect">redirect target <tt>&key</tt> host port protocol add-session-id permanently => |</a> + +<blockquote> Sends back appropriate headers to redirect the client +to <code>target</code> (a string). + +If <code>target</code> is a full URL starting with a scheme, <code>host</code>, <code>port</code>, and <code>protocol</code> +are ignored. Otherwise, <code>target</code> should denote the path part of a +URL, <code>protocol</code> must be one of the keywords <code>:HTTP</code> or <code>:HTTPS</code>, and +the URL to redirect to will be constructed from <code>host</code>, <code>port</code>, <code>protocol</code>, +and <code>target</code>. + +If <code>permanently</code> +is true (the default is <code>NIL</code>), a 301 status +code will be sent, otherwise a 302 status code. If <code>host</code> +is not provided, the current host (see <a +href="#host"><code>HOST</code></a>) will be +used. If <code>protocol</code> is the +keyword <code>:HTTPS</code>, the client will be redirected to a https +URL, if it's <code>:HTTP</code> it'll be sent to a http URL. If +both <code>host</code> and <code>protocol</code> aren't +provided, then the value of <code>protocol</code> will +match the current request. +</blockquote> + + [Function] + <a class=none name="require-authorization">require-authorization <tt>&optional</tt> realm => |</a> + +<blockquote> +Sends back appropriate headers to require basic HTTP authentication (see <a href='http://www.faqs.org/rfcs/rfc2617.html'>RFC 2617</a>) for the realm <code>realm</code>. The default value for <code>realm</code> is <code>"Hunchentoot"</code>. +</blockquote> + + [Function] + <a class=none name="escape-for-html">escape-for-html string => escaped-string</a> + +<blockquote> +Escapes all occurrences of the characters <code>#\<</code>, <code>#\></code>, <code>#\'</code>, <code>#"</code>, and <code>#\&</code> within <code>string</code> for HTML output. +</blockquote> + + [Function] + <a class=none name="url-encode">url-encode string <tt>&optional</tt> external-format => url-encoded-string</a> + +<blockquote> +URL-encodes a string using the external format <code>external-format</code>. The default for <code>external-format</code> is the value of <a href="#*hunchentoot-default-external-format*"><code>*HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*</code></a>. +</blockquote> + + [Function] + <a class=none name="url-decode">url-decode string <tt>&optional</tt> external-format => url-encoded-string</a> + +<blockquote> +URL-decodes a string using the external format <code>external-format</code>, i.e. this is the inverse of <a href="#url-encode"><code>URL-ENCODE</code></a>. +It is assumed that you'll rarely need this function, if ever. But just in case - here it is. +The default for <code>external-format</code> is the value of <a href="#*hunchentoot-default-external-format*"><code>*HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*</code></a>. +</blockquote> + + [Function] + <a class=none name="http-token-p">http-token-p object => generalized-boolean</a> + +<blockquote> This function tests +whether <code>object</code> is a non-empty string which is +a token according to <a href='http://www.faqs.org/rfcs/rfc2068.html'>RFC 2068</a> (i.e. whether it may be used +for, say, cookie names). +</blockquote> + + [Special variable] + <a class=none name="*tmp-directory*">*tmp-directory*</a> + +<blockquote> +This should be a pathname denoting a directory where temporary files can be stored. It is used for <a href="#upload">file uploads</a>. +</blockquote> + + [Special variable] + <a class=none +name="*hunchentoot-default-external-format*">*hunchentoot-default-external-format*</a> + +<blockquote> The (<a href="http://weitz.de/flexi-streams/">flexi +stream</a>) external format used when computing +the <a href="#requests"><code>REQUEST</code></a> object. The default +value is the result of evaluating +<pre> +(<a class=noborder href="http://weitz.de/flexi-streams/#make-external-format">flex:make-external-format</a> :latin1 :eol-style :lf) +</pre> +</blockquote> + + [Function] + <a class=none name="mime-type">mime-type pathspec => string</a> + +<blockquote> +Given a pathname designator <code>pathspec</code> returns the <a href="http://en.wikipedia.org/wiki/Internet_media_type">MIME type</a> +(as a string) corresponding to the suffix of the file denoted by +<code>pathspec</code> (or <code>NIL</code> if none can be +found). This is based on the table coming with the Apache +distribution with some additions. +</blockquote> + + [Function] + <a class=none name="reason-phrase">reason-phrase return-code => string</a> + +<blockquote> Returns a reason phrase for the HTTP return +code <code>return-code</code> (which should be an integer) +or <code>NIL</code> for return codes Hunchentoot doesn't know. +</blockquote> + +   <h3><a class=none name="ht-mp">The HUNCHENTOOT-MP package</a></h3> + +Hunchentoot creates an +additional <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/11_.htm">package</a> <code>HUNCHENTOOT-MP</code> +which exports a couple of MP-related symbols +(namely <code>*CURRENT-PROCESS*</code>, <code>MAKE-LOCK</code>, <code>WITH-LOCK</code>, <code>PROCESS-RUN-FUNCTION</code>, +and <code>PROCESS-KILL</code>). These functions and macros have to be +in Hunchentoot's small portability shim anyway and even if you don't +spawn your own threads there might be occasions where you want to at +least use the lock-related functionality to write thread-safe portable +code. See the corresponding documentation strings and/or the source +code for more information. + +   <h3><a class=none name="performance">Performance</a></h3> + +If you're concerned about Hunchentoot's performance, you should first +and foremost check if you aren't wasting your time with premature +optimization. Make a reasonable estimate of the amount of traffic +your website should be able to handle and don't try to benchmark for +loads Google would be proud of. Here's a part of an interview with +someone called John Witchel about his experiences with his +company Red Gorilla that can't be quoted often enough (it +seems the original source of the interview has vanished): + +<blockquote> +Q: If you could go back and change anything, would Red Gorilla still be +in business today? + +A: Yes. I would start small and grow as the demand grew. That's what I'm +doing now. + +Back then we planned to be huge from the outset. So we built this +monster platform on BEA, Sun and Oracle. We had huge dedicated +connectivity pipes. We had two full racks clustered and fully +redundant. We had E450's with RAID-5 and all 4 CPU slots filled, +E250s, F5 load balancers... the cost of keeping that system on was +enormous. The headcount to keep it humming was enormous too. + +The truth is, we could have run the whole company on my laptop using a +cable modem connection. +</blockquote> + +Having said that, my experience is that Hunchentoot doesn't have to +hide when it comes to +serving <a href="#handle-static-file">static files</a>. If +you really have performance problems with Hunchentoot, there +are two things I'm aware of you should watch out for. +<ul> +<li>Check how your Lisp implementation implements multi-processing. +While I write this (April 2007), some Lisps, like CMUCL, still use +their +own <a +href="http://en.wikipedia.org/wiki/Multithreading">green +threads</a>, and some others, like AllegroCL and LispWorks, use +OS-threads but allow only one Lisp thread at a time. Unless you're +using a Lisp that employs "real" symmetric multi-processing like SBCL +(on some platforms) or OpenMCL, you shouldn't compare apples with +oranges. (Note: For CMUCL, you also shouldn't forget to use the +dreaded <a +href="http://wiki.alu.org/Lisp_Gotchas"><code>MP::STARTUP-IDLE-AND-TOP-LEVEL-LOOPS</code></a>.) +<li>All text output sent from <a href="#handlers">handlers</a> goes +through two layers +of <a +href="http://www.nhplace.com/kent/CL/Issues/stream-definition-by-user.html">Gray +streams</a> by default +(<a href="http://weitz.de/flexi-streams/">FLEXI-STREAMS</a> +and <a href="http://weitz.de/chunga/">Chunga</a>). This isn't an +issue for small to medium-sized pages, but can be for large ones. +There are several ways to cope with this +- <a +href="http://common-lisp.net/pipermail/tbnl-devel/2007-March/001093.html">return +binary data from +handlers</a>, <a +href="http://common-lisp.net/pipermail/tbnl-devel/2007-March/001099.html">bypass +FLEXI-STREAMS</a>, sit behind <a href="#mod_lisp">mod_lisp</a>, etc. +Try it, and if you really think that Hunchentoot is too slow +for what you're trying to do and what you'll need, ask on +the <a href="#href">mailing list</a> and we'll try to help. +</ul> + +   <h3><a class=none name="history">History</a></h3> + +Hunchentoot's predecessor <a href="http://weitz.de/tbnl/">TBNL</a> +(which is short for "To Be Named Later") grew over the years +as a toolkit that I used for various commercial and private +projects. In August 2003, Daniel Barlow started +a <a href='http://article.gmane.org/gmane.lisp.web/148'>review of web +APIs</a> on the <a href='http://www.red-bean.com/lispweb/'>lispweb</a> +mailing list and +I <a href='http://article.gmane.org/gmane.lisp.web/153'>described</a> +the API of my hitherto-unreleased bunch of code (and christened it +"TBNL"). + +It turned out that <a href='http://www.jeffcaldwell.com/'>Jeff +Caldwell</a> had worked on something similar so he emailed me and +proposed to join our efforts. As I had no immediate plans to release +my code (which was poorly organized, undocumented, and mostly +CMUCL-specific), I gave it to Jeff and he worked towards a release. He +added docstrings, refactored, added some stuff, and based it on KMRCL +to make it portable across several Lisp implementations. + +Unfortunately, Jeff is at least as busy as I am so he didn't find the +time to finish a full release. But in spring 2004 I needed a +documented version of the code for a client of mine who thought +it would be good if the toolkit were publicly available under an open +source license. So I took Jeff's code, refactored again (to sync with +the changes I had done in the meantime), and added documentation. +This resulted in TBNL 0.1.0 (which initially required mod_lisp as its +front-end). Jeff's code (which includes a lot more stuff that I +didn't use) is still available from his own +website <a href='http://tbnl.org/'>tbnl.org</a>. + +In March 2005, Bob Hutchinson sent patches which enabled TBNL to use +other front-ends than mod_lisp. This made me aware that TBNL was +already almost a full web server, so eventually I wrote +Hunchentoot which was a full web server, implemented as a +wrapper around TBNL. Hunchentoot 0.1.0 was released at the end of +2005 and was originally LispWorks-only. + +Hunchentoot 0.4.0, released in October 2006, was the first release +which also worked with other Common Lisp implementations. It is a +major rewrite and also incorporates most of TBNL and replaces +it completely. + +   <h3><a class=none name="index">Symbol index</a></h3> + +Here are all exported symbols of the <code>HUNCHENTOOT</code> package +in alphabetical order linked to their corresponding entries: + + <ul> + <li><a href="#*approved-return-codes*"><code>*approved-return-codes*</code></a> + <li><a href="#*catch-errors-p*"><code>*catch-errors-p*</code></a> + <li><a href="#*cleanup-function*"><code>*cleanup-function*</code></a> + <li><a href="#*cleanup-interval*"><code>*cleanup-interval*</code></a> + <li><a href="#*content-types-for-url-rewrite*"><code>*content-types-for-url-rewrite*</code></a> + <li><a href="#*default-content-type*"><code>*default-content-type*</code></a> + <li><a href="#*default-handler*"><code>*default-handler*</code></a> + <li><a href="#*default-log-level*"><code>*default-log-level*</code></a> + <li><a href="#*default-read-timeout*"><code>*default-read-timeout*</code></a> + <li><a href="#*default-write-timeout*"><code>*default-write-timeout*</code></a> + <li><a href="#*dispatch-table*"><code>*dispatch-table*</code></a> + <li><a href="#*file-upload-hook*"><code>*file-upload-hook*</code></a> + <li><a href="#*handle-http-errors-p*"><code>*handle-http-errors-p*</code></a> + <li><a href="#*header-stream*"><code>*header-stream*</code></a> + <li><a href="#*http-error-handler*"><code>*http-error-handler*</code></a> + <li><a href="#*hunchentoot-default-external-format*"><code>*hunchentoot-default-external-format*</code></a> + <li><a href="#*lisp-errors-log-level*"><code>*lisp-errors-log-level*</code></a> + <li><a href="#*lisp-warnings-log-level*"><code>*lisp-warnings-log-level*</code></a> + <li><a href="#*log-lisp-backtraces-p*"><code>*log-lisp-backtraces-p*</code></a> + <li><a href="#*log-lisp-errors-p*"><code>*log-lisp-errors-p*</code></a> + <li><a href="#*log-lisp-warnings-p*"><code>*log-lisp-warnings-p*</code></a> + <li><a href="#*log-prefix*"><code>*log-prefix*</code></a> + <li><a href="#*meta-dispatcher*"><code>*meta-dispatcher*</code></a> + <li><a href="#*methods-for-post-parameters*"><code>*methods-for-post-parameters*</code></a> + <li><a href="#*reply*"><code>*reply*</code></a> + <li><a href="#*request*"><code>*request*</code></a> + <li><a href="#*rewrite-for-session-urls*"><code>*rewrite-for-session-urls*</code></a> + <li><a href="#*server*"><code>*server*</code></a> + <li><a href="#*session*"><code>*session*</code></a> + <li><a href="#*session-cookie-name*"><code>*session-cookie-name*</code></a> + <li><a href="#*session-gc-frequency*"><code>*session-gc-frequency*</code></a> + <li><a href="#*session-max-time*"><code>*session-max-time*</code></a> + <li><a href="#*session-removal-hook*"><code>*session-removal-hook*</code></a> + <li><a href="#*show-access-log-messages*"><code>*show-access-log-messages*</code></a> + <li><a href="#*show-lisp-backtraces-p*"><code>*show-lisp-backtraces-p*</code></a> + <li><a href="#*show-lisp-errors-p*"><code>*show-lisp-errors-p*</code></a> + <li><a href="#*tmp-directory*"><code>*tmp-directory*</code></a> + <li><a href="#*use-remote-addr-for-sessions*"><code>*use-remote-addr-for-sessions*</code></a> + <li><a href="#*use-user-agent-for-sessions*"><code>*use-user-agent-for-sessions*</code></a> + <li><a href="#+http-accepted+"><code>+http-accepted+</code></a> + <li><a href="#+http-authorization-required+"><code>+http-authorization-required+</code></a> + <li><a href="#+http-bad-gateway+"><code>+http-bad-gateway+</code></a> + <li><a href="#+http-bad-request+"><code>+http-bad-request+</code></a> + <li><a href="#+http-conflict+"><code>+http-conflict+</code></a> + <li><a href="#+http-continue+"><code>+http-continue+</code></a> + <li><a href="#+http-created+"><code>+http-created+</code></a> + <li><a href="#+http-expectation-failed+"><code>+http-expectation-failed+</code></a> + <li><a href="#+http-failed-dependency+"><code>+http-failed-dependency+</code></a> + <li><a href="#+http-forbidden+"><code>+http-forbidden+</code></a> + <li><a href="#+http-gateway-time-out+"><code>+http-gateway-time-out+</code></a> + <li><a href="#+http-gone+"><code>+http-gone+</code></a> + <li><a href="#+http-internal-server-error+"><code>+http-internal-server-error+</code></a> + <li><a href="#+http-length-required+"><code>+http-length-required+</code></a> + <li><a href="#+http-method-not-allowed+"><code>+http-method-not-allowed+</code></a> + <li><a href="#+http-moved-permanently+"><code>+http-moved-permanently+</code></a> + <li><a href="#+http-moved-temporarily+"><code>+http-moved-temporarily+</code></a> + <li><a href="#+http-multi-status+"><code>+http-multi-status+</code></a> + <li><a href="#+http-multiple-choices+"><code>+http-multiple-choices+</code></a> + <li><a href="#+http-no-content+"><code>+http-no-content+</code></a> + <li><a href="#+http-non-authoritative-information+"><code>+http-non-authoritative-information+</code></a> + <li><a href="#+http-not-acceptable+"><code>+http-not-acceptable+</code></a> + <li><a href="#+http-not-found+"><code>+http-not-found+</code></a> + <li><a href="#+http-not-implemented+"><code>+http-not-implemented+</code></a> + <li><a href="#+http-not-modified+"><code>+http-not-modified+</code></a> + <li><a href="#+http-ok+"><code>+http-ok+</code></a> + <li><a href="#+http-partial-content+"><code>+http-partial-content+</code></a> + <li><a href="#+http-payment-required+"><code>+http-payment-required+</code></a> + <li><a href="#+http-precondition-failed+"><code>+http-precondition-failed+</code></a> + <li><a href="#+http-proxy-authentication-required+"><code>+http-proxy-authentication-required+</code></a> + <li><a href="#+http-request-entity-too-large+"><code>+http-request-entity-too-large+</code></a> + <li><a href="#+http-request-time-out+"><code>+http-request-time-out+</code></a> + <li><a href="#+http-request-uri-too-large+"><code>+http-request-uri-too-large+</code></a> + <li><a href="#+http-requested-range-not-satisfiable+"><code>+http-requested-range-not-satisfiable+</code></a> + <li><a href="#+http-reset-content+"><code>+http-reset-content+</code></a> + <li><a href="#+http-see-other+"><code>+http-see-other+</code></a> + <li><a href="#+http-service-unavailable+"><code>+http-service-unavailable+</code></a> + <li><a href="#+http-switching-protocols+"><code>+http-switching-protocols+</code></a> + <li><a href="#+http-temporary-redirect+"><code>+http-temporary-redirect+</code></a> + <li><a href="#+http-unsupported-media-type+"><code>+http-unsupported-media-type+</code></a> + <li><a href="#+http-use-proxy+"><code>+http-use-proxy+</code></a> + <li><a href="#+http-version-not-supported+"><code>+http-version-not-supported+</code></a> + <li><a href="#authorization"><code>authorization</code></a> + <li><a href="#aux-request-value"><code>aux-request-value</code></a> + <li><a href="#content-length"><code>content-length</code></a> + <li><a href="#content-type"><code>content-type</code></a> + <li><a href="#cookie-domain"><code>cookie-domain</code></a> + <li><a href="#cookie-expires"><code>cookie-expires</code></a> + <li><a href="#cookie-http-only"><code>cookie-http-only</code></a> + <li><a href="#cookie-in"><code>cookie-in</code></a> + <li><a href="#cookie-name"><code>cookie-name</code></a> + <li><a href="#cookie-out"><code>cookie-out</code></a> + <li><a href="#cookie-path"><code>cookie-path</code></a> + <li><a href="#cookie-secure"><code>cookie-secure</code></a> + <li><a href="#cookie-value"><code>cookie-value</code></a> + <li><a href="#cookies-in"><code>cookies-in</code></a> + <li><a href="#cookies-out"><code>cookies-out</code></a> + <li><a href="#create-folder-dispatcher-and-handler"><code>create-folder-dispatcher-and-handler</code></a> + <li><a href="#create-prefix-dispatcher"><code>create-prefix-dispatcher</code></a> + <li><a href="#create-regex-dispatcher"><code>create-regex-dispatcher</code></a> + <li><a href="#create-static-file-dispatcher-and-handler"><code>create-static-file-dispatcher-and-handler</code></a> + <li><a href="#default-dispatcher"><code>default-dispatcher</code></a> + <li><a href="#define-easy-handler"><code>define-easy-handler</code></a> + <li><a href="#delete-aux-request-value"><code>delete-aux-request-value</code></a> + <li><a href="#delete-session-value"><code>delete-session-value</code></a> + <li><a href="#dispatch-easy-handlers"><code>dispatch-easy-handlers</code></a> + <li><a href="#dispatch-request"><code>dispatch-request</code></a> + <li><a href="#do-sessions"><code>do-sessions</code></a> + <li><a href="#escape-for-html"><code>escape-for-html</code></a> + <li><a href="#get-backtrace"><code>get-backtrace</code></a> + <li><a href="#get-parameter"><code>get-parameter</code></a> + <li><a href="#get-parameters"><code>get-parameters</code></a> + <li><a href="#handle-if-modified-since"><code>handle-if-modified-since</code></a> + <li><a href="#handle-static-file"><code>handle-static-file</code></a> + <li><a href="#handler-done"><code>handler-done</code></a> + <li><a href="#header-in"><code>header-in</code></a> + <li><a href="#header-out"><code>header-out</code></a> + <li><a href="#headers-in"><code>headers-in</code></a> + <li><a href="#headers-out"><code>headers-out</code></a> + <li><a href="#host"><code>host</code></a> + <li><a href="#http-token-p"><code>http-token-p</code></a> + <li><a href="#log-file"><code>log-file</code></a> + <li><a href="#log-message"><code>log-message</code></a> + <li><a href="#log-message*"><code>log-message*</code></a> + <li><a href="#maybe-invoke-debugger"><code>maybe-invoke-debugger</code></a> + <li><a href="#mime-type"><code>mime-type</code></a> + <li><a href="#mod-lisp-id"><code>mod-lisp-id</code></a> + <li><a href="#no-cache"><code>no-cache</code></a> + <li><a href="#parameter"><code>parameter</code></a> + <li><a href="#post-parameter"><code>post-parameter</code></a> + <li><a href="#post-parameters"><code>post-parameters</code></a> + <li><a href="#query-string"><code>query-string</code></a> + <li><a href="#raw-post-data"><code>raw-post-data</code></a> + <li><a href="#real-remote-addr"><code>real-remote-addr</code></a> + <li><a href="#reason-phrase"><code>reason-phrase</code></a> + <li><a href="#recompute-request-parameters"><code>recompute-request-parameters</code></a> + <li><a href="#redirect"><code>redirect</code></a> + <li><a href="#referer"><code>referer</code></a> + <li><a href="#remote-addr"><code>remote-addr</code></a> + <li><a href="#remote-port"><code>remote-port</code></a> + <li><a href="#remote-session"><code>remote-session</code></a> + <li><a href="#reply-external-format"><code>reply-external-format</code></a> + <li><a href="#request-method"><code>request-method</code></a> + <li><a href="#request-uri"><code>request-uri</code></a> + <li><a href="#require-authorization"><code>require-authorization</code></a> + <li><a href="#reset-sessions"><code>reset-sessions</code></a> + <li><a href="#return-code"><code>return-code</code></a> + <li><a href="#rfc-1123-date"><code>rfc-1123-date</code></a> + <li><a href="#script-name"><code>script-name</code></a> + <li><a href="#send-headers"><code>send-headers</code></a> + <li><a href="#server-addr"><code>server-addr</code></a> + <li><a href="#server-address"><code>server-address</code></a> + <li><a href="#server-dispatch-table"><code>server-dispatch-table</code></a> + <li><a href="#server-local-port"><code>server-local-port</code></a> + <li><a href="#server-name"><code>server-name</code></a> + <li><a href="#server-port"><code>server-port</code></a> + <li><a href="#server-protocol"><code>server-protocol</code></a> + <li><a href="#session-cookie-value"><code>session-cookie-value</code></a> + <li><a href="#session-counter"><code>session-counter</code></a> + <li><a href="#session-gc"><code>session-gc</code></a> + <li><a href="#session-max-time"><code>session-max-time</code></a> + <li><a href="#session-too-old-p"><code>session-too-old-p</code></a> + <li><a href="#session-remote-addr"><code>session-remote-addr</code></a> + <li><a href="#session-user-agent"><code>session-user-agent</code></a> + <li><a href="#session-value"><code>session-value</code></a> + <li><a href="#set-cookie"><code>set-cookie</code></a> + <li><a href="#set-cookie*"><code>set-cookie*</code></a> + <li><a href="#ssl-p"><code>ssl-p</code></a> + <li><a href="#ssl-session-id"><code>ssl-session-id</code></a> + <li><a href="#start-server"><code>start-server</code></a> + <li><a href="#start-session"><code>start-session</code></a> + <li><a href="#stop-server"><code>stop-server</code></a> + <li><a href="#url-decode"><code>url-decode</code></a> + <li><a href="#url-encode"><code>url-encode</code></a> + <li><a href="#user-agent"><code>user-agent</code></a> + </ul> + +   <h3><a class=none name="ack">Acknowledgements</a></h3> + +Thanks to Jeff Caldwell - TBNL would not have been released without +his efforts. Thanks to <a href="http://www.fractalconcept.com/">Marc +Battyani</a> for mod_lisp and +to <a href="http://www.swiss.ai.mit.edu/~cph/">Chris Hanson</a> for +mod_lisp2. Thanks +to <a href="http://www.cliki.net/Stefan%20Scholl">Stefan Scholl</a> +and Travis Cross for various additions and fixes to TBNL, +to <a href="http://www.foldr.org/~michaelw/">Michael Weber</a> for +initial file upload code, and +to <a href="http://www.ltn.lv/~jonis/">Janis Dzerins</a> for +his <a href="http://common-lisp.net/project/rfc2388/">RFC 2388 +code</a>. Thanks to Bob Hutchison for his code for multiple front-ends +(which made me realize that TBNL was already pretty close to a "real" +web server) and the initial UTF-8 example. Thanks to John +Foderaro's <a +href="http://opensource.franz.com/aserve/index.html">AllegroServe</a> +for inspiration. Thanks +to <a href="http://www.htg1.de/">Uwe von Loh</a> for the <a href="http://www.htg1.de/hunchentoot/hunchentoot.html">Hunchentoot +logo</a>. + +Hunchentoot originally used code +from <a href="http://www.cliki.net/ACL-COMPAT">ACL-COMPAT</a>, +specifically the chunking code from Jochen Schmidt. (This has been +replaced by <a href="http://weitz.de/chunga/">Chunga</a>.) When I +ported Hunchentoot to other Lisps than LispWorks, I stole code from +ACL-COMPAT, <a href="http://www.cliki.net/kmrcl">KMRCL</a>, +and <a href="http://www.cliki.net/trivial-sockets">trivial-sockets</a> +for implementation-dependent stuff like sockets and MP. + +Parts of this documentation were prepared +with <a +href="http://weitz.de/documentation-template/">DOCUMENTATION-TEMPLATE</a>, no animals were harmed. + + +$Header: /usr/local/cvsrep/hunchentoot/doc/index.html,v 1.126 2007/12/29 17:35:03 edi Exp $ +<a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a> + +</body> +</html> Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/easy-handlers.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/easy-handlers.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,319 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/easy-handlers.lisp,v 1.12 2007/05/25 11:32:50 edi Exp $ + +;;; Copyright (c) 2004-2007, 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 compute-real-name (symbol) + "Computes the `real' paramater name \(a string) from the Lisp +symbol SYMBOL. Used in cases where no parameter name is +provided." + ;; we just downcase the symbol's name + (string-downcase symbol)) + +(defun convert-parameter (argument type) + "Converts the string ARGUMENT to TYPE where TYPE is one of the +symbols STRING, CHARACTERS, INTEGER, KEYWORD, or BOOLEAN - or +otherwise a function designator for a function of one argument. +ARGUMENT can also be NIL in which case this function also returns +NIL unconditionally." + (when (listp argument) + ;; this if for the case that ARGUMENT is NIL or the result of a + ;; file upload + (return-from convert-parameter argument)) + (case type + (string argument) + (character (and (= (length argument) 1) + (char argument 0))) + (integer (ignore-errors (parse-integer argument :junk-allowed t))) + (keyword (make-keyword argument :destructivep nil)) + (boolean t) + (otherwise (funcall type argument)))) + +(defun compute-simple-parameter (parameter-name type parameter-reader) + "Retrieves the parameter named PARAMETER-NAME using the reader +PARAMETER-READER and converts it to TYPE." + (convert-parameter (funcall parameter-reader parameter-name) type)) + +(defun compute-list-parameter (parameter-name type parameters) + "Retrieves all parameters from PARAMETERS which are named +PARAMETER-NAME, converts them to TYPE, and returns a list of +them." + (loop for (name . value) in parameters + when (string= name parameter-name) + collect (convert-parameter value type))) + +(defun compute-array-parameter (parameter-name type parameters) + "Retrieves all parameters from PARAMETERS which are named like +\"PARAMETER-NAME[N]\" \(where N is a non-negative integer), +converts them to TYPE, and returns an array where the Nth element +is the corresponding value." + ;; see <http://common-lisp.net/pipermail/tbnl-devel/2006-September/000660.html> + #+:sbcl (declare (sb-ext:muffle-conditions warning)) + (let* ((index-value-list + (loop for (full-name . value) in parameters + for index = (register-groups-bind (name index-string) + ("^(.*)\\[(\\d+)\\]$" full-name) + (when (string= name parameter-name) + (parse-integer index-string))) + when index + collect (cons index (convert-parameter value type)))) + (array (make-array (1+ (reduce #'max index-value-list + :key #'car + :initial-value -1)) + :initial-element nil))) + (loop for (index . value) in index-value-list + do (setf (aref array index) value)) + array)) + +(defun compute-hash-table-parameter (parameter-name type parameters key-type test-function) + "Retrieves all parameters from PARAMETERS which are named like +\"PARAMETER-NAME{FOO}\" \(where FOO is any sequence of characters +not containing curly brackets), converts them to TYPE, and +returns a hash table with test function TEST-FUNCTION where the +corresponding value is associated with the key FOO \(converted to +KEY-TYPE)." + (let ((hash-table (make-hash-table :test test-function))) + (loop for (full-name . value) in parameters + for key = (register-groups-bind (name key-string) + ("^(.*){([^{}]+)}$" full-name) + (when (string= name parameter-name) + (convert-parameter key-string key-type))) + when key + do (setf (gethash key hash-table) + (convert-parameter value type))) + hash-table)) + +(defun compute-parameter (parameter-name parameter-type request-type) + "Computes and returns the parameter\(s) called PARAMETER-NAME +and converts it/them according to the value of PARAMETER-TYPE. +REQUEST-TYPE is one of :GET, :POST, or :BOTH." + (when (member parameter-type '(list array hash-table)) + (setq parameter-type (list parameter-type 'string))) + (let ((parameter-reader (ecase request-type + (:get #'get-parameter) + (:post #'post-parameter) + (:both #'parameter))) + (parameters (and (listp parameter-type) + (case request-type + (:get (get-parameters)) + (:post (post-parameters)) + (:both (append (get-parameters) (post-parameters))))))) + (cond ((atom parameter-type) + (compute-simple-parameter parameter-name parameter-type parameter-reader)) + ((and (null (cddr parameter-type)) + (eq (first parameter-type) 'list)) + (compute-list-parameter parameter-name (second parameter-type) parameters)) + ((and (null (cddr parameter-type)) + (eq (first parameter-type) 'array)) + (compute-array-parameter parameter-name (second parameter-type) parameters)) + ((and (null (cddddr parameter-type)) + (eq (first parameter-type) 'hash-table)) + (compute-hash-table-parameter parameter-name (second parameter-type) parameters + (or (third parameter-type) 'string) + (or (fourth parameter-type) 'equal))) + (t (error "Don't know what to do with parameter type ~S." parameter-type))))) + +(defun make-defun-parameter (description default-parameter-type default-request-type) + "Creates a keyword parameter to be used by DEFINE-EASY-HANDLER. +DESCRIPTION is one of the elements of DEFINE-EASY-HANDLER's +LAMBDA-LIST and DEFAULT-PARAMETER-TYPE and DEFAULT-REQUEST-TYPE +are the global default values." + (when (atom description) + (setq description (list description))) + (destructuring-bind (parameter-name &key (real-name (compute-real-name parameter-name)) + parameter-type init-form request-type) + description + `(,parameter-name (or (and (boundp '*request*) + (compute-parameter ,real-name + ,(or parameter-type default-parameter-type) + ,(or request-type default-request-type))) + ,init-form)))) + +(defmacro define-easy-handler (description lambda-list &body body) + "Defines a handler with the body BODY and optionally registers +it with a URI so that it will be found by DISPATCH-EASY-HANDLERS. +DESCRIPTION is either a symbol NAME or a list matching the +destructuring lambda list + + (name &key uri server-names default-parameter-type default-request-type). + +LAMBDA-LIST is a list the elements of which are either a symbol +VAR or a list matching the destructuring lambda list + + (var &key real-name parameter-type init-form request-type). + +The resulting handler will be a Lisp function with the name NAME +and keyword parameters named by the VAR symbols. Each VAR will +be bound to the value of the GET or POST parameter called +REAL-NAME \(a string) before BODY is executed. If REAL-NAME is +not provided, it will be computed by downcasing the symbol name +of VAR. + +If URI \(which is evaluated) is provided, then it must be a string or +a function designator for a function of one argument. In this case, +the handler will be returned by DISPATCH-EASY-HANDLERS, if URI is a +string and the script name of a request is URI, or if URI designates a +function and applying this function to the current request object +returns a true value. + +SERVER-NAMES \(which is evaluated) can be a list of symbols which +means that the handler will be returned by DISPATCH-EASY-HANDLERS in +servers which have one of these names \(see SERVER-NAME). +SERVER-NAMES can also be the symbol T which means that the handler +will be returned by DISPATCH-EASY-HANDLERS in every server. + +Whether the GET or POST parameter \(or both) will be taken into +consideration, depends on REQUEST-TYPE which can +be :GET, :POST, :BOTH, or NIL. In the last case, the value of +DEFAULT-REQUEST-TYPE \(the default of which is :BOTH) will be +used. + +The value of VAR will usually be a string \(unless it resulted from a +file upload in which case it won't be converted at all), but if +PARAMETER-TYPE \(which is evaluated) is provided, the string will be +converted to another Lisp type by the following rules: + +If the corresponding GET or POST parameter wasn't provided by the +client, VAR's value will be NIL. If PARAMETER-TYPE is 'STRING, VAR's +value remains as is. If PARAMETER-TYPE is 'INTEGER and the parameter +string consists solely of decimal digits, VAR's value will be the +corresponding integer, otherwise NIL. If PARAMETER-TYPE is 'KEYWORD, +VAR's value will be the keyword obtained by interning the upcased +parameter string into the keyword package. If PARAMETER-TYPE is +'CHARACTER and the parameter string is of length one, VAR's value will +be the single character of this string, otherwise NIL. If +PARAMETER-TYPE is 'BOOLEAN, VAR's value will always be T \(unless it +is NIL by the first rule above, of course). If PARAMETER-TYPE is any +other atom, it is supposed to be a function designator for a unary +function which will be called to convert the string to something else. + +Those were the rules for `simple' types, but PARAMETER-TYPE can +also be a list starting with one of the symbols LIST, ARRAY, or +HASH-TABLE. The second value of the list must always be a simple +parameter type as in the last paragraph - we'll call it the +`inner type' below. + +In the case of 'LIST, all GET/POST parameters called REAL-NAME +will be collected, converted to the inner type, and assembled +into a list which will be the value of VAR. + +In the case of 'ARRAY, all GET/POST parameters which have a name +like the result of + + (format nil \"~A[~A]\" real-name n) + +where N is a non-negative integer, will be assembled into an +array where the Nth element will be set accordingly, after +conversion to the inner type. The array, which will become the +value of VAR, will be big enough to hold all matching parameters, +but not bigger. Array elements not set as described above will +be NIL. Note that VAR will always be bound to an array, which +may be empty, so it will never be NIL, even if no appropriate +GET/POST parameters are found. + +The full form of a 'HASH-TABLE parameter type is + + (hash-table inner-type key-type test-function), + +but KEY-TYPE and TEST-FUNCTION can be left out in which case they +default to 'STRING and 'EQUAL, respectively. For this parameter +type, all GET/POST parameters which have a name like the result +of + + (format nil \"~A{~A}\" real-name key) + +\(where KEY is a string that doesn't contain curly brackets) will +become the values \(after conversion to INNER-TYPE) of a hash +table with test function TEST-FUNCTION where KEY \(after +conversion to KEY-TYPE) will be the corresponding key. Note that +VAR will always be bound to a hash table, which may be empty, so +it will never be NIL, even if no appropriate GET/POST parameters +are found. + +To make matters even more complicated, the three compound +parameter types also have an abbreviated form - just one of the +symbols LIST, ARRAY, or HASH-TABLE. In this case, the inner type +will default to 'STRING. + +If PARAMETER-TYPE is not provided or NIL, DEFAULT-PARAMETER-TYPE +\(the default of which is 'STRING) will be used instead. + +If the result of the computations above would be that VAR would +be bound to NIL, then INIT-FORM \(if provided) will be evaluated +instead, and VAR will be bound to the result of this evaluation. + +Handlers built with this macro are constructed in such a way that +the resulting Lisp function is useful even outside of +Hunchentoot. Specifically, all the parameter computations above +will only happen if *REQUEST* is bound, i.e. if we're within a +Hunchentoot request. Otherwise, VAR will always be bound to the +result of evaluating INIT-FORM unless a corresponding keyword +argument is provided." + (when (atom description) + (setq description (list description))) + (destructuring-bind (name &key uri (server-names t) + (default-parameter-type ''string) + (default-request-type :both)) + description + `(progn + ,@(when uri + (list + (with-rebinding (uri) + `(progn + (setq *easy-handler-alist* + (delete-if (lambda (list) + (or (equal ,uri (first list)) + (eq ',name (third list)))) + *easy-handler-alist*)) + (push (list ,uri ,server-names ',name) *easy-handler-alist*))))) + (defun ,name (&key ,@(loop for part in lambda-list + collect (make-defun-parameter part + default-parameter-type + default-request-type))) + ,@body)))) + +;; help the LispWorks IDE to find these definitions +#+:lispworks +(dspec:define-form-parser define-easy-handler (description) + `(,define-easy-handler ,(if (atom description) description (first description)))) + +#+:lispworks +(dspec:define-dspec-alias define-easy-handler (name) + `(defun ,name)) + +(defun dispatch-easy-handlers (request) + "This is a dispatcher which returns the appropriate handler +defined with DEFINE-EASY-HANDLER, if there is one." + (loop for (uri server-names easy-handler) in *easy-handler-alist* + when (and (or (eq server-names t) + (find (server-name *server*) server-names :test #'eq)) + (cond ((stringp uri) + (string= (script-name request) uri)) + (t (funcall uri request)))) + do (return easy-handler))) Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/headers.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/headers.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,323 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/headers.lisp,v 1.25 2007/12/29 17:35:00 edi Exp $ + +;;; Copyright (c) 2004-2007, 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 maybe-write-to-header-stream (key &optional value) + (when *header-stream* + (format *header-stream* "~A~@[: ~A~]~%" key + (and value (regex-replace-all "[\\r\\n]" value " "))) + (force-output *header-stream*))) + +(defun compute-length (content) + "Computes and returns the length of CONTENT in octets. Returns as a +second value CONTENT as a vector of octets. The result depends on the +external format of *REPLY*." + (when (null content) + (return-from compute-length)) + (when (stringp content) + (setq content + (string-to-octets content :external-format (reply-external-format)))) + (values (length content) content)) + +(defmethod write-header-line ((mod-lisp-p (eql nil)) key value) + "Accepts strings KEY and VALUE and writes them directly to the +client as an HTTP header line." + (write-string key *hunchentoot-stream*) + (write-string ": " *hunchentoot-stream*) + ;; remove line breaks + (write-string (regex-replace-all "[\\r\\n]" value " ") *hunchentoot-stream*) + (write-string +crlf+ *hunchentoot-stream*)) + +(defmethod write-header-line (mod-lisp-p key value) + "Accepts strings KEY and VALUE and writes them, one line at a time, +to the mod_lisp socket stream." + (write-line key *hunchentoot-stream*) + ;; remove line breaks + (write-line (regex-replace-all "[\\r\\n]" value " ") *hunchentoot-stream*)) + +(defmethod write-header-line :after (mod-lisp-p key value) + (declare (ignorable mod-lisp-p)) + (maybe-write-to-header-stream key value)) + +(defun start-output (&optional (content nil content-provided-p)) + "Sends all headers and maybe the content body to +*HUNCHENTOOT-STREAM*. Returns immediately and does nothing if called +more than once per request. Handles the supported return codes +accordingly. Called by PROCESS-REQUEST and/or SEND-HEADERS. Returns +the stream to write to." + ;; send headers only once + (when *headers-sent* + (return-from start-output)) + (setq *headers-sent* t) + ;; read post data to clear stream + (raw-post-data) + (let* ((mod-lisp-p (server-mod-lisp-p *server*)) + (return-code (return-code)) + (chunkedp (and (server-output-chunking-p *server*) + (eq (server-protocol) :http/1.1) + ;; only turn chunking on if the content + ;; length is unknown at this point... + (null (or (content-length) content-provided-p)) + ;; ...AND if the return code isn't one where + ;; Hunchentoot (or a user error handler) sends its + ;; own content + (member return-code *approved-return-codes*))) + (reason-phrase (reason-phrase return-code)) + (request-method (request-method)) + (head-request-p (eq request-method :head)) + content-modified-p) + (unless mod-lisp-p + (multiple-value-bind (keep-alive-p keep-alive-requested-p) + (keep-alive-p) + (when keep-alive-p + (setq keep-alive-p + ;; use keep-alive if there's a way for the client to + ;; determine when all content is sent (or if there + ;; is no content) + (or chunkedp + head-request-p + (eq (return-code) +http-not-modified+) + (content-length) + content))) + ;; now set headers for keep-alive and chunking + (when chunkedp + (setf (header-out "Transfer-Encoding") "chunked")) + (cond (keep-alive-p + (setf *close-hunchentoot-stream* nil) + (when (or (not (eq (server-protocol) :http/1.1)) + keep-alive-requested-p) + ;; persistent connections are implicitly assumed for + ;; HTTP/1.1, but we return a 'Keep-Alive' header if the + ;; client has explicitly asked for one + (setf (header-out "Connection") "Keep-Alive" + (header-out "Keep-Alive") + (format nil "timeout=~D" (server-read-timeout *server*))))) + (t (setf (header-out "Connection") "Close")))) + (unless (and (header-out-set-p "Server") + (null (header-out "Server"))) + (setf (header-out "Server") (or (header-out "Server") + (server-name-header)))) + (setf (header-out "Date") (rfc-1123-date))) + (unless reason-phrase + (setq content (escape-for-html + (format nil "Unknown http return code: ~A" return-code)) + content-modified-p t + return-code +http-internal-server-error+ + reason-phrase (reason-phrase return-code))) + (unless (or (not *handle-http-errors-p*) + (member return-code *approved-return-codes*)) + ;; call error handler, if any - should return NIL if it can't + ;; handle the error + (let (error-handled-p) + (when *http-error-handler* + (setq error-handled-p (funcall *http-error-handler* return-code) + content (or error-handled-p content) + content-modified-p (or content-modified-p error-handled-p))) + ;; handle common return codes other than 200, which weren't + ;; handled by the error handler + (unless error-handled-p + (setf (content-type) + "text/html; charset=iso-8859-1" + content-modified-p t + content + (format nil "<html><head><title>~D ~A</title></head><body><h1>~:*~A</h1>~A<hr>~A</body></html>" + return-code reason-phrase + (case return-code + ((#.+http-internal-server-error+) content) + ((#.+http-moved-temporarily+ #.+http-moved-permanently+) + (format nil "The document has moved <a href='~A'>here</a>" + (header-out "Location"))) + ((#.+http-authorization-required+) + "The server could not verify that you are authorized to access the document requested. Either you supplied the wrong credentials \(e.g., bad password), or your browser doesn't understand how to supply the credentials required.") + ((#.+http-forbidden+) + (format nil "You don't have permission to access ~A on this server." + (script-name))) + ((#.+http-not-found+) + (format nil "The requested URL ~A was not found on this server." + (script-name))) + ((#.+http-bad-request+) + "Your browser sent a request that this server could not understand.") + (otherwise "")) + (address-string)))))) + ;; start with status line + (cond (mod-lisp-p + (write-header-line t "Status" (format nil "~D ~A" return-code reason-phrase))) + (t + (let ((first-line + (format nil "HTTP/1.1 ~D ~A" return-code reason-phrase))) + (write-string first-line *hunchentoot-stream*) + (write-string +crlf+ *hunchentoot-stream*) + (maybe-write-to-header-stream first-line)))) + (when (and (stringp content) + (not content-modified-p) + (starts-with-one-of-p (or (content-type) "") + *content-types-for-url-rewrite*)) + ;; if the Content-Type header starts with one of the strings + ;; in *CONTENT-TYPES-FOR-URL-REWRITE* then maybe rewrite the + ;; content + (setq content (maybe-rewrite-urls-for-session content))) + (let ((content-length (content-length))) + (unless content-length + (multiple-value-setq (content-length content) (compute-length content))) + ;; write the corresponding headers for the content + (when content-length + (write-header-line mod-lisp-p "Content-Length" (format nil "~D" content-length)) + (when mod-lisp-p + (write-header-line t "Lisp-Content-Length" + (cond (head-request-p "0") + (t (format nil "~D" content-length)))) + (write-header-line t "Keep-Socket" "1") + (setq *close-hunchentoot-stream* nil))) + (when-let (content-type (content-type)) + (write-header-line mod-lisp-p "Content-Type" content-type)) + ;; write all headers from the REPLY object + (loop for (key . value) in (headers-out) + when value + do (write-header-line mod-lisp-p (string-capitalize key) value)) + ;; now the cookies + (loop for (nil . cookie) in (cookies-out) + do (write-header-line mod-lisp-p "Set-Cookie" (stringify-cookie cookie))) + (when mod-lisp-p + ;; send log messages to mod_lisp + (loop for (log-level . message) in (reverse (log-messages *reply*)) + do (write-header-line t (case log-level + ((:emerg) "Log-Emerg") + ((:alert) "Log-Alert") + ((:crit) "Log-Crit") + ((:error) "Log-Error") + ((:warning) "Log-Warning") + ((:notice) "Log-Notice") + ((:info) "Log-Info") + ((:debug) "Log-Debug") + (otherwise "Log")) + message))) + ;; all headers sent + (cond (mod-lisp-p + (write-line "end" *hunchentoot-stream*) + (maybe-write-to-header-stream "end")) + (t + (write-string +crlf+ *hunchentoot-stream*) + (maybe-write-to-header-stream ""))) + ;; access log message + (when (and *show-access-log-messages* + (not (server-use-apache-log-p *server*))) + (ignore-errors + (log-message nil "~:[-~@[ (~A)~]~;~:*~A~@[ (~A)~]~] ~:[-~;~:*~A~] \"~A ~A~@[?~A~] ~A\" ~A ~:[~*-~;~D~] \"~:[-~;~:*~A~]\" \"~:[-~;~:*~A~]\"" + (remote-addr) (header-in :x-forwarded-for) + (authorization) request-method (script-name) + (query-string) (server-protocol) + return-code content content-length + (referer) (user-agent))))) + (setf (flexi-stream-external-format *hunchentoot-stream*) (reply-external-format)) + ;; now optional content + (unless (or (null content) head-request-p) + (ignore-errors + #+:clisp + (unless (stringp content) + (setf (flexi-stream-element-type *hunchentoot-stream*) 'octet)) + (write-sequence content *hunchentoot-stream*))) + (when chunkedp + ;; turn chunking on after the headers have been sent + (setf (chunked-stream-output-chunking-p + (flexi-stream-stream *hunchentoot-stream*)) t)) + *hunchentoot-stream*)) + +(defun send-headers () + "Sends the initial status line and all headers as determined by +the REPLY object *REPLY*. Returns a stream to which the body of +the reply can be written. Once this function has been called, +further changes to *REPLY* don't have any effect. Also, +automatic handling of errors \(i.e. sending the corresponding +status code to the browser, etc.) is turned off for this request. +If your handlers return the full body as a string or as an array +of octets you should NOT call this function." + (start-output)) + +(defun get-request-data () + "Reads incoming headers from mod_lisp or directly from the client +via *HUNCHENTOOT-STREAM*. Returns as multiple values the headers as +an alist, the stream to read the request body from, the method, the +URI, and the protocol of the request. The last three values are only +returned if we're not behind mod_lisp." + (ignore-errors + (let* ((mod-lisp-p (server-mod-lisp-p *server*)) + (first-line (if mod-lisp-p + (read-line *hunchentoot-stream* nil nil) + (cl:handler-case + (read-line* *hunchentoot-stream*) + ((or end-of-file + #+:sbcl sb-sys:io-timeout + #+:cmu sys:io-timeout + #+:allegro excl:socket-error) () + nil))))) + (cond ((null first-line) + ;; socket closed - return immediately + nil) + (mod-lisp-p + ;; we're behind mod_lisp, so we read alternating + ;; key/value lines + (let ((second-line (read-line *hunchentoot-stream* t))) + (maybe-write-to-header-stream first-line second-line) + (let* ((headers + (loop for key = (read-line *hunchentoot-stream* nil nil) + while (and key (string-not-equal key "end")) + for value = (read-line *hunchentoot-stream* t) + collect (cons (make-keyword key) value) + do (maybe-write-to-header-stream key value))) + (content-length (cdr (assoc :content-length headers)))) + ;; add contents of first two lines + (push (cons (make-keyword first-line) second-line) headers) + (values (delete-duplicates headers :test #'eq :key #'car) + (and (or content-length + (server-input-chunking-p *server*)) + *hunchentoot-stream*))))) + (t + ;; we're a stand-alone web server, so we use Chunga to + ;; read the headers + (destructuring-bind (method url-string &optional protocol) + (split "\\s+" first-line :limit 3) + (maybe-write-to-header-stream first-line) + (let ((headers (and protocol (read-http-headers *hunchentoot-stream* + *header-stream*)))) + (unless protocol (setq protocol "HTTP/0.9")) + (when (equalp (cdr (assoc :expect headers)) "100-continue") + ;; handle 'Expect: 100-continue' header + (let ((continue-line + (format nil "HTTP/1.1 ~D ~A" + +http-continue+ + (reason-phrase +http-continue+)))) + (write-string continue-line *hunchentoot-stream*) + (write-string +crlf+ *hunchentoot-stream*) + (write-string +crlf+ *hunchentoot-stream*) + (force-output *hunchentoot-stream*) + (maybe-write-to-header-stream continue-line) + (maybe-write-to-header-stream ""))) + (values headers *hunchentoot-stream* (make-keyword method) url-string + (make-keyword (string-trim '(#\Space #\Tab #\NewLine #\Return) protocol)))))))))) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/hunchentoot-test.asd ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/hunchentoot-test.asd Thu Feb 7 03:16:29 2008 @@ -0,0 +1,35 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/hunchentoot-test.asd,v 1.2 2007/01/01 23:50:30 edi Exp $ + +;;; Copyright (c) 2004-2007, 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. + +(asdf:defsystem :hunchentoot-test + :components ((:module "test" + :serial t + :components ((:file "packages") + (:file "test")))) + :depends-on (:hunchentoot :cl-who)) Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/hunchentoot.asd ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/hunchentoot.asd Thu Feb 7 03:16:29 2008 @@ -0,0 +1,81 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/hunchentoot.asd,v 1.53 2007/12/29 17:35:01 edi Exp $ + +;;; Copyright (c) 2004-2007, 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 :cl-user) + +(defpackage :hunchentoot-asd + (:use :cl :asdf)) + +(in-package :hunchentoot-asd) + +(defvar *hunchentoot-version* "0.15.0" + "A string denoting the current version of Hunchentoot. Used +for diagnostic output.") + +(export '*hunchentoot-version*) + +(asdf:defsystem :hunchentoot + :serial t + :version #.*hunchentoot-version* + :depends-on (:chunga + :cl-base64 + :cl-ppcre + #-(or :lispworks :hunchentoot-no-ssl) :cl+ssl + :md5 + :rfc2388 + #+:sbcl :sb-bsd-sockets + #+:sbcl :sb-posix + #+:openmcl :acl-compat + :url-rewrite) + :components ((:file "packages") + (:file "conditions") + #+:allegro (:file "port-acl") + #+:clisp (:file "port-clisp") + #+:cmu (:file "port-cmu") + #+:lispworks (:file "port-lw") + #+:openmcl (:file "port-mcl") + #+:sbcl (:file "port-sbcl") + (:file "specials") + (:file "mime-types") + (:file "util") + (:file "log") + (:file "cookie") + (:file "reply") + (:file "request") + (:file "session") + (:file "misc") + (:file "easy-handlers") + (:file "headers") + #+(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") + (:file "server"))) Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/log.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/log.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,93 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/log.lisp,v 1.9 2007/10/19 23:51:32 edi Exp $ + +;;; Copyright (c) 2004-2007, 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) + +(defgeneric log-message (log-level fmt &rest args)) + +(defmethod log-message (log-level fmt &rest args) + "Sends a formatted message to Apache's error log when the data gets +sent to Apache/mod_lisp and SERVER-USE-APACHE-LOG-P is true, otherwise +logs to the file denoted by LOG-FILE. FMT and ARGS are as in FORMAT. +LOG-LEVEL is a keyword denoting the corresponding Apache error level." + (let ((message (apply #'format nil fmt args))) + (cond ((and (boundp '*server*) + (server-mod-lisp-p *server*) + (server-use-apache-log-p *server*)) + (with-input-from-string (s message) + (loop with prolog = (case *log-prefix* + ((nil) "") + ((t) "[Hunchentoot] ") + (otherwise (format nil "[~A] " *log-prefix*))) + for line = (read-line s nil nil) + while line + do (push (cons log-level + (format nil "~A~A" prolog line)) + (slot-value *reply* 'log-messages))))) + (t (with-lock (*log-file-lock*) + (ignore-errors + (unless *log-file-stream* + (let ((log-file-stream + (open (ensure-directories-exist *log-file*) + :direction :output + :element-type 'octet + :if-does-not-exist :create + :if-exists :append + #+:openmcl #+:openmcl + :sharing :lock))) + (setq *log-file-stream* + (make-flexi-stream log-file-stream + :external-format +utf-8+)))) + (handler-case + (format *log-file-stream* + "[~A~@[ [~A]~]] ~A~%" (iso-time) log-level message) + (error () + (format *log-file-stream* "[~A [EMERG]] A message could not be logged!" + (iso-time)))) + (force-output *log-file-stream*)))))) + (values)) + +(defun log-message* (fmt &rest args) + "Same as LOG-MESSAGE* but with the default log level \(as +defined by *DEFAULT-LOG-LEVEL*)." + (apply #'log-message *default-log-level* fmt args)) + +(defun log-file () + "Returns the log file which is currently used." + *log-file*) + +(defun (setf log-file) (pathspec) + "Sets the log file which is to be used." + (with-lock (*log-file-lock*) + (when *log-file-stream* + (ignore-errors + (close *log-file-stream*)) + (setq *log-file-stream* nil)) + (setq *log-file* pathspec))) + \ No newline at end of file Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/mime-types.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/mime-types.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,362 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/mime-types.lisp,v 1.3 2007/01/01 23:50:30 edi Exp $ + +;;; Copyright (c) 2004-2007, 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) + +(defparameter *mime-type-list* '(("application/andrew-inset" "ez") + ("application/cu-seeme" "cu") + ("application/dsptype" "tsp") + ("application/futuresplash" "spl") + ("application/hta" "hta") + ("application/java-archive" "jar") + ("application/java-serialized-object" "ser") + ("application/java-vm" "class") + ("application/mac-binhex40" "hqx") + ("application/mac-compactpro" "cpt") + ("application/mathematica" "nb") + ("application/msaccess" "mdb") + ("application/msword" "doc" "dot") + ("application/octet-stream" "bin") + ("application/oda" "oda") + ("application/ogg" "ogg") + ("application/pdf" "pdf") + ("application/pgp-keys" "key") + ("application/pgp-signature" "pgp") + ("application/pics-rules" "prf") + ("application/postscript" "ps" "ai" "eps") + ("application/rar" "rar") + ("application/rdf+xml" "rdf") + ("application/rss+xml" "rss") + ("application/smil" "smi" "smil") + ("application/wordperfect" "wpd") + ("application/wordperfect5.1" "wp5") + ("application/xhtml+xml" "xhtml" "xht") + ("application/xml" "fo" "xml" "xsl") + ("application/zip" "zip") + ("application/vnd.cinderella" "cdy") + ("application/vnd.mozilla.xul+xml" "xul") + ("application/vnd.ms-excel" "xls" "xlb" "xlt") + ("application/vnd.ms-pki.seccat" "cat") + ("application/vnd.ms-pki.stl" "stl") + ("application/vnd.ms-powerpoint" "ppt" "pps") + ("application/vnd.oasis.opendocument.chart" "odc") + ("application/vnd.oasis.opendocument.database" "odb") + ("application/vnd.oasis.opendocument.formula" "odf") + ("application/vnd.oasis.opendocument.graphics" "odg") + ("application/vnd.oasis.opendocument.graphics-template" "otg") + ("application/vnd.oasis.opendocument.image" "odi") + ("application/vnd.oasis.opendocument.presentation" "odp") + ("application/vnd.oasis.opendocument.presentation-template" "otp") + ("application/vnd.oasis.opendocument.spreadsheet" "ods") + ("application/vnd.oasis.opendocument.spreadsheet-template" "ots") + ("application/vnd.oasis.opendocument.text" "odt") + ("application/vnd.oasis.opendocument.text-master" "odm") + ("application/vnd.oasis.opendocument.text-template" "ott") + ("application/vnd.oasis.opendocument.text-web" "oth") + ("application/vnd.rim.cod" "cod") + ("application/vnd.smaf" "mmf") + ("application/vnd.stardivision.calc" "sdc") + ("application/vnd.stardivision.draw" "sda") + ("application/vnd.stardivision.impress" "sdd" "sdp") + ("application/vnd.stardivision.math" "smf") + ("application/vnd.stardivision.writer" "sdw" "vor") + ("application/vnd.stardivision.writer-global" "sgl") + ("application/vnd.sun.xml.calc" "sxc") + ("application/vnd.sun.xml.calc.template" "stc") + ("application/vnd.sun.xml.draw" "sxd") + ("application/vnd.sun.xml.draw.template" "std") + ("application/vnd.sun.xml.impress" "sxi") + ("application/vnd.sun.xml.impress.template" "sti") + ("application/vnd.sun.xml.math" "sxm") + ("application/vnd.sun.xml.writer" "sxw") + ("application/vnd.sun.xml.writer.global" "sxg") + ("application/vnd.sun.xml.writer.template" "stw") + ("application/vnd.symbian.install" "sis") + ("application/vnd.visio" "vsd") + ("application/vnd.wap.wbxml" "wbxml") + ("application/vnd.wap.wmlc" "wmlc") + ("application/vnd.wap.wmlscriptc" "wmlsc") + ("application/x-123" "wk") + ("application/x-abiword" "abw") + ("application/x-apple-diskimage" "dmg") + ("application/x-bcpio" "bcpio") + ("application/x-bittorrent" "torrent") + ("application/x-cdf" "cdf") + ("application/x-cdlink" "vcd") + ("application/x-chess-pgn" "pgn") + ("application/x-cpio" "cpio") + ("application/x-csh" "csh") + ("application/x-debian-package" "deb" "udeb") + ("application/x-director" "dcr" "dir" "dxr") + ("application/x-dms" "dms") + ("application/x-doom" "wad") + ("application/x-dvi" "dvi") + ("application/x-flac" "flac") + ("application/x-font" "pfa" "pfb" "gsf" "pcf") + ("application/x-freemind" "mm") + ("application/x-futuresplash" "spl") + ("application/x-gnumeric" "gnumeric") + ("application/x-go-sgf" "sgf") + ("application/x-graphing-calculator" "gcf") + ("application/x-gtar" "gtar" "tgz" "taz") + ("application/x-hdf" "hdf") + ("application/x-httpd-php" "phtml" "pht" "php") + ("application/x-httpd-php-source" "phps") + ("application/x-httpd-php3" "php3") + ("application/x-httpd-php3-preprocessed" "php3p") + ("application/x-httpd-php4" "php4") + ("application/x-ica" "ica") + ("application/x-internet-signup" "ins" "isp") + ("application/x-iphone" "iii") + ("application/x-iso9660-image" "iso") + ("application/x-java-jnlp-file" "jnlp") + ("application/x-javascript" "js") + ("application/x-jmol" "jmz") + ("application/x-kchart" "chrt") + ("application/x-killustrator" "kil") + ("application/x-koan" "skp" "skd" "skt" "skm") + ("application/x-kpresenter" "kpr" "kpt") + ("application/x-kspread" "ksp") + ("application/x-kword" "kwd" "kwt") + ("application/x-latex" "latex") + ("application/x-lha" "lha") + ("application/x-lzh" "lzh") + ("application/x-lzx" "lzx") + ("application/x-maker" "frm" "maker" "frame" "fm" "fb" "book" "fbdoc") + ("application/x-mif" "mif") + ("application/x-ms-wmd" "wmd") + ("application/x-ms-wmz" "wmz") + ("application/x-msdos-program" "com" "exe" "bat" "dll") + ("application/x-msi" "msi") + ("application/x-netcdf" "nc") + ("application/x-ns-proxy-autoconfig" "pac") + ("application/x-nwc" "nwc") + ("application/x-object" "o") + ("application/x-oz-application" "oza") + ("application/x-pkcs7-certreqresp" "p7r") + ("application/x-pkcs7-crl" "crl") + ("application/x-python-code" "pyc" "pyo") + ("application/x-quicktimeplayer" "qtl") + ("application/x-redhat-package-manager" "rpm") + ("application/x-sh" "sh") + ("application/x-shar" "shar") + ("application/x-shockwave-flash" "swf" "swfl") + ("application/x-stuffit" "sit") + ("application/x-sv4cpio" "sv4cpio") + ("application/x-sv4crc" "sv4crc") + ("application/x-tar" "tar") + ("application/x-tcl" "tcl") + ("application/x-tex-gf" "gf") + ("application/x-tex-pk" "pk") + ("application/x-texinfo" "texinfo" "texi") + ("application/x-trash" "~%" "" "bak" "old" "sik") + ("application/x-troff" "tt" "r" "roff") + ("application/x-troff-man" "man") + ("application/x-troff-me" "me") + ("application/x-troff-ms" "ms") + ("application/x-ustar" "ustar") + ("application/x-wais-source" "src") + ("application/x-wingz" "wz") + ("application/x-x509-ca-cert" "crt") + ("application/x-xcf" "xcf") + ("application/x-xfig" "fig") + ("application/x-xpinstall" "xpi") + ("audio/basic" "au" "snd") + ("audio/midi" "mid" "midi" "kar") + ("audio/mpeg" "mpga" "mpega" "mp2" "mp3" "m4a") + ("audio/mpegurl" "m3u") + ("audio/prs.sid" "sid") + ("audio/x-aiff" "aif" "aiff" "aifc") + ("audio/x-gsm" "gsm") + ("audio/x-mpegurl" "m3u") + ("audio/x-ms-wma" "wma") + ("audio/x-ms-wax" "wax") + ("audio/x-pn-realaudio" "ra" "rm" "ram") + ("audio/x-realaudio" "ra") + ("audio/x-scpls" "pls") + ("audio/x-sd2" "sd2") + ("audio/x-wav" "wav") + ("chemical/x-alchemy" "alc") + ("chemical/x-cache" "cac" "cache") + ("chemical/x-cache-csf" "csf") + ("chemical/x-cactvs-binary" "cbin" "cascii" "ctab") + ("chemical/x-cdx" "cdx") + ("chemical/x-cerius" "cer") + ("chemical/x-chem3d" "c3d") + ("chemical/x-chemdraw" "chm") + ("chemical/x-cif" "cif") + ("chemical/x-cmdf" "cmdf") + ("chemical/x-cml" "cml") + ("chemical/x-compass" "cpa") + ("chemical/x-crossfire" "bsd") + ("chemical/x-csml" "csml" "csm") + ("chemical/x-ctx" "ctx") + ("chemical/x-cxf" "cxf" "cef") + ("chemical/x-embl-dl-nucleotide" "emb" "embl") + ("chemical/x-galactic-spc" "spc") + ("chemical/x-gamess-input" "inp" "gam" "gamin") + ("chemical/x-gaussian-checkpoint" "fch" "fchk") + ("chemical/x-gaussian-cube" "cub") + ("chemical/x-gaussian-input" "gau" "gjc" "gjf") + ("chemical/x-gaussian-log" "gal") + ("chemical/x-gcg8-sequence" "gcg") + ("chemical/x-genbank" "gen") + ("chemical/x-hin" "hin") + ("chemical/x-isostar" "istr" "ist") + ("chemical/x-jcamp-dx" "jdx" "dx") + ("chemical/x-kinemage" "kin") + ("chemical/x-macmolecule" "mcm") + ("chemical/x-macromodel-input" "mmd" "mmod") + ("chemical/x-mdl-molfile" "mol") + ("chemical/x-mdl-rdfile" "rd") + ("chemical/x-mdl-rxnfile" "rxn") + ("chemical/x-mdl-sdfile" "sd" "sdf") + ("chemical/x-mdl-tgf" "tgf") + ("chemical/x-mmcif" "mcif") + ("chemical/x-mol2" "mol2") + ("chemical/x-molconn-Z" "b") + ("chemical/x-mopac-graph" "gpt") + ("chemical/x-mopac-input" "mop" "mopcrt" "mpc" "dat" "zmt") + ("chemical/x-mopac-out" "moo") + ("chemical/x-mopac-vib" "mvb") + ("chemical/x-ncbi-asn1" "asn") + ("chemical/x-ncbi-asn1-ascii" "prt" "ent") + ("chemical/x-ncbi-asn1-binary" "val" "aso") + ("chemical/x-ncbi-asn1-spec" "asn") + ("chemical/x-pdb" "pdb" "ent") + ("chemical/x-rosdal" "ros") + ("chemical/x-swissprot" "sw") + ("chemical/x-vamas-iso14976" "vms") + ("chemical/x-vmd" "vmd") + ("chemical/x-xtel" "xtel") + ("chemical/x-xyz" "xyz") + ("image/gif" "gif") + ("image/ief" "ief") + ("image/jpeg" "jpeg" "jpg" "jpe") + ("image/pcx" "pcx") + ("image/png" "png") + ("image/svg+xml" "svg" "svgz") + ("image/tiff" "tiff" "tif") + ("image/vnd.djvu" "djvu" "djv") + ("image/vnd.wap.wbmp" "wbmp") + ("image/x-cmu-raster" "ras") + ("image/x-coreldraw" "cdr") + ("image/x-coreldrawpattern" "pat") + ("image/x-coreldrawtemplate" "cdt") + ("image/x-corelphotopaint" "cpt") + ("image/x-icon" "ico") + ("image/x-jg" "art") + ("image/x-jng" "jng") + ("image/x-ms-bmp" "bmp") + ("image/x-photoshop" "psd") + ("image/x-portable-anymap" "pnm") + ("image/x-portable-bitmap" "pbm") + ("image/x-portable-graymap" "pgm") + ("image/x-portable-pixmap" "ppm") + ("image/x-rgb" "rgb") + ("image/x-xbitmap" "xbm") + ("image/x-xpixmap" "xpm") + ("image/x-xwindowdump" "xwd") + ("model/iges" "igs" "iges") + ("model/mesh" "msh" "mesh" "silo") + ("model/vrml" "wrl" "vrml") + ("text/calendar" "ics" "icz") + ("text/comma-separated-values" "csv") + ("text/css" "css") + ("text/h323" "323") + ("text/html" "html" "htm" "shtml") + ("text/iuls" "uls") + ("text/mathml" "mml") + ("text/plain" "asc" "txt" "text" "diff" "pot") + ("text/richtext" "rtx") + ("text/rtf" "rtf") + ("text/scriptlet" "sct" "wsc") + ("text/texmacs" "tm" "ts") + ("text/tab-separated-values" "tsv") + ("text/vnd.sun.j2me.app-descriptor" "jad") + ("text/vnd.wap.wml" "wml") + ("text/vnd.wap.wmlscript" "wmls") + ("text/x-bibtex" "bib") + ("text/x-boo" "boo") + ("text/x-c++hdr" "h++" "hpp" "hxx" "hh") + ("text/x-c++src" "c++" "cpp" "cxx" "cc") + ("text/x-chdr" "h") + ("text/x-component" "htc") + ("text/x-csh" "csh") + ("text/x-csrc" "c") + ("text/x-dsrc" "d") + ("text/x-haskell" "hs") + ("text/x-java" "java") + ("text/x-literate-haskell" "lhs") + ("text/x-moc" "moc") + ("text/x-pascal" "pp" "as") + ("text/x-pcs-gcd" "gcd") + ("text/x-perl" "pl" "pm") + ("text/x-python" "py") + ("text/x-setext" "etx") + ("text/x-sh" "sh") + ("text/x-tcl" "tcl" "tk") + ("text/x-tex" "tex" "ltx" "sty" "cls") + ("text/x-vcalendar" "vcs") + ("text/x-vcard" "vcf") + ("video/dl" "dl") + ("video/dv" "dif" "dv") + ("video/fli" "fli") + ("video/gl" "gl") + ("video/mpeg" "mpeg" "mpg" "mpe") + ("video/mp4" "mp4") + ("video/quicktime" "qt" "mov") + ("video/vnd.mpegurl" "mxu") + ("video/x-la-asf" "lsf" "lsx") + ("video/x-mng" "mng") + ("video/x-ms-asf" "asf" "asx") + ("video/x-ms-wm" "wm") + ("video/x-ms-wmv" "wmv") + ("video/x-ms-wmx" "wmx") + ("video/x-ms-wvx" "wvx") + ("video/x-msvideo" "avi") + ("video/x-sgi-movie" "movie") + ("x-conference/x-cooltalk" "ice") + ("x-world/x-vrml" "vrm" "vrml" "wrl")) + "An alist where the cars are MIME types and the cdrs are list +of file suffixes for the corresponding type.") + +(defparameter *mime-type-hash* + (let ((hash (make-hash-table :test #'equalp))) + (loop for (type . suffixes) in *mime-type-list* do + (loop for suffix in suffixes do + (setf (gethash suffix hash) type))) + hash) + "A hash table which maps file suffixes to MIME types.") + +(defun mime-type (pathspec) + "Given a pathname designator PATHSPEC returns the MIME type +\(as a string) corresponding to the suffix of the file denoted by +PATHSPEC \(or NIL)." + (gethash (pathname-type pathspec) *mime-type-hash*)) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/misc.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/misc.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,276 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/misc.lisp,v 1.13 2007/12/29 17:35:01 edi Exp $ + +;;; Copyright (c) 2004-2007, 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) + +(let ((scanner-hash (make-hash-table :test #'equal))) + (defun scanner-for-get-param (param-name) + "Returns a CL-PPCRE scanner which matches a GET parameter in a +URL. Scanners are memoized in SCANNER-HASH once they are created." + (or (gethash param-name scanner-hash) + (setf (gethash param-name scanner-hash) + (create-scanner + `(:alternation + ;; session=value at end of URL + (:sequence + (:char-class #\? #\&) + ,param-name + #\= + (:greedy-repetition 0 nil (:inverted-char-class #\&)) + :end-anchor) + ;; session=value with other parameters following + (:sequence + (:register (:char-class #\? #\&)) + ,param-name + #\= + (:greedy-repetition 0 nil (:inverted-char-class #\&)) + #\&)))))) + (defun add-cookie-value-to-url (url &key (cookie-name *session-cookie-name*) + (value (session-cookie-value)) + (replace-ampersands-p t)) + "Removes all GET parameters named COOKIE-NAME from URL and then +adds a new GET parameter with the name COOKIE-NAME and the value +VALUE. If REPLACE-AMPERSANDS-P is true all literal ampersands in URL +are replaced with '&'. The resulting URL is returned." + (unless url + ;; see URL-REWRITE:*URL-REWRITE-FILL-TAGS* + (setq url (request-uri *request*))) + (setq url (regex-replace-all (scanner-for-get-param cookie-name) url "\\1")) + (when value + (setq url (format nil "~A~:[?~;&~]~A=~A" + url + (find #\? url) + cookie-name + (url-encode value)))) + (when replace-ampersands-p + (setq url (regex-replace-all "&" url "&"))) + url)) + +(defun maybe-rewrite-urls-for-session (html &key (cookie-name *session-cookie-name*) + (value (session-cookie-value))) + "Rewrites the HTML page HTML such that the name/value pair +COOKIE-NAME/COOKIE-VALUE is inserted if the client hasn't sent a +cookie of the same name but only if *REWRITE-FOR-SESSION-URLS* is +true. See the docs for URL-REWRITE:REWRITE-URLS." + (cond ((or (not *rewrite-for-session-urls*) + (null value) + (cookie-in cookie-name)) + html) + (t + (with-input-from-string (*standard-input* html) + (with-output-to-string (*standard-output*) + (url-rewrite:rewrite-urls + (lambda (url) + (add-cookie-value-to-url url + :cookie-name cookie-name + :value value)))))))) + +(defmethod dispatch-request (dispatch-table) + "Dispatches *REQUEST* based upon rules in the DISPATCH-TABLE. +This method provides the default Hunchentoot behavior." + (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 default-dispatcher (request) + "Default dispatch function which handles every request with the +function stored in *DEFAULT-HANDLER*." + (declare (ignore request)) + *default-handler*) + +(defun default-handler () + "The handler that is supposed to serve the request if no other +handler is called." + (log-message :info "Default handler called for script ~A" (script-name)) + (format nil "<html><head><title>Hunchentoot</title></head><body><h2>Hunchentoot Default Page</h2>This the Hunchentoot default page. You're most likely seeing it because the server administrator hasn't set up a custom default page yet.Hunchentoot is a web server written in <a href='http://www.lisp.org/'>Common Lisp</a>. More info about Hunchentoot can be found at <a href='http://weitz.de/hunchentoot/'>http://weitz.de/hunchentoot/</a>.<hr>~A</body></html>" + (address-string))) + +(defun create-prefix-dispatcher (prefix page-function) + "Creates a dispatch function which will dispatch to the +function denoted by PAGE-FUNCTION if the file name of the current +request starts with the string PREFIX." + (lambda (request) + (let ((mismatch (mismatch (script-name request) prefix + :test #'char=))) + (and (or (null mismatch) + (>= mismatch (length prefix))) + page-function)))) + +(defun create-regex-dispatcher (regex page-function) + "Creates a dispatch function which will dispatch to the +function denoted by PAGE-FUNCTION if the file name of the current +request matches the CL-PPCRE regular expression REGEX." + (let ((scanner (create-scanner regex))) + (lambda (request) + (and (scan scanner (script-name request)) + page-function)))) + +(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 +CONTENT-TYPE or \(if that is NIL) tries to determine the content +type via the file's suffix." + (unless (or (pathname-name path) + (pathname-type path)) + ;; not a file + (setf (return-code) +http-bad-request+) + (throw 'handler-done nil)) + (unless (probe-file path) + ;; does not exist + (setf (return-code) +http-not-found+) + (throw 'handler-done nil)) + (let ((time (or (file-write-date path) (get-universal-time)))) + (setf (content-type) (or content-type + (mime-type path) + "application/octet-stream")) + (handle-if-modified-since time) + (with-open-file (file path + :direction :input + :element-type 'octet + :if-does-not-exist nil) + (setf (header-out "Last-Modified") (rfc-1123-date time) + (content-length) (file-length file)) + (let ((out (send-headers))) + #+:clisp + (setf (flexi-stream-element-type *hunchentoot-stream*) 'octet) + (loop with buf = (make-array +buffer-length+ :element-type 'octet) + for pos = (read-sequence buf file) + until (zerop pos) + do (write-sequence buf out :end pos) + (finish-output out)))))) + +(defun create-static-file-dispatcher-and-handler (uri path &optional content-type) + "Creates and returns a dispatch function which will dispatch to a +handler function which emits the file denoted by the pathname +designator PATH with content type CONTENT-TYPE if the SCRIPT-NAME of +the request matches the string URI. If CONTENT-TYPE is NIL tries to +determine the content type via the file's suffix." + ;; the dispatcher + (lambda (request) + (when (equal (script-name request) uri) + ;; the handler + (lambda () + (handle-static-file path content-type))))) + +(defun enough-url (url url-prefix) + "Returns the relative portion of URL relative to URL-PREFIX, similar +to what ENOUGH-NAMESTRING does for pathnames." + (subseq url (mismatch url url-prefix))) + +(defun create-folder-dispatcher-and-handler (uri-prefix base-path &optional content-type) + "Creates and returns a dispatch function which will dispatch to a +handler function which emits the file relative to BASE-PATH that is +denoted by the URI of the request relative to URI-PREFIX. URI-PREFIX +must be a string ending with a slash, BASE-PATH must be a pathname +designator for an existing directory. If CONTENT-TYPE is not NIL, +it'll be the content type used for all files in the folder." + (unless (and (stringp uri-prefix) + (plusp (length uri-prefix)) + (char= (char uri-prefix (1- (length uri-prefix))) #\/)) + (error "~S must be string ending with a slash." uri-prefix)) + (when (or (pathname-name base-path) + (pathname-type base-path)) + (error "~S is supposed to denote a directory." base-path)) + (flet ((handler () + (let* ((script-name (url-decode (script-name))) + (script-path (enough-url (regex-replace-all "\\\\" script-name "/") + uri-prefix)) + (script-path-directory (pathname-directory script-path))) + (unless (or (stringp script-path-directory) + (null script-path-directory) + (and (listp script-path-directory) + (eq (first script-path-directory) :relative) + (loop for component in (rest script-path-directory) + always (stringp component)))) + (setf (return-code) +http-forbidden+) + (throw 'handler-done nil)) + (handle-static-file (merge-pathnames script-path base-path) content-type)))) + (create-prefix-dispatcher uri-prefix #'handler))) + +(defun no-cache () + "Adds appropriate headers to completely prevent caching on most browsers." + (setf (header-out "Expires") + "Mon, 26 Jul 1997 05:00:00 GMT" + (header-out "Cache-Control") + "no-store, no-cache, must-revalidate, post-check=0, pre-check=0" + (header-out "Pragma") + "no-cache" + (header-out "Last-Modified") + (rfc-1123-date)) + (values)) + +(defun ssl-p () + "Whether the current connection to the client is secure." + (cond ((server-mod-lisp-p *server*) (ssl-session-id *request*)) + (t #-:hunchentoot-no-ssl (server-ssl-certificate-file *server*) + #+:hunchentoot-no-ssl nil))) + +(defun redirect (target &key (host (host *request*) host-provided-p) + port + (protocol (if (ssl-p) :https :http)) + (add-session-id (not (or host-provided-p + (starts-with-scheme-p target) + (cookie-in *session-cookie-name*)))) + permanently) + "Redirects the browser to TARGET which should be a string. If +TARGET is a full URL starting with a scheme, HOST, PORT and PROTOCOL +are ignored. Otherwise, TARGET should denote the path part of a URL, +PROTOCOL must be one of the keywords :HTTP or :HTTPS, and the URL to +redirect to will be constructed from HOST, PORT, PROTOCOL, and TARGET. +Adds a session ID if ADD-SESSION-ID is true. If PERMANENTLY is true, +a 301 request is sent to the browser, otherwise a 302." + (let ((url (if (starts-with-scheme-p target) + target + (format nil "~A://~A~@[:~A~]~A" + (ecase protocol + ((:http) "http") + ((:https) "https")) + (if port + (first (ppcre:split ":" (or host ""))) + host) + port target)))) + (when add-session-id + (setq url (add-cookie-value-to-url url :replace-ampersands-p nil))) + (setf (header-out :location) + url + (return-code *reply*) + (if permanently + +http-moved-permanently+ + +http-moved-temporarily+)) + (throw 'handler-done nil))) + +(defun require-authorization (&optional (realm "Hunchentoot")) + "Sends back appropriate headers to require basic HTTP authentication +\(see RFC 2617) for the realm REALM." + (setf (header-out "WWW-Authenticate") + (format nil "Basic realm=\"~A\"" (quote-string realm)) + (return-code *reply*) + +http-authorization-required+) + (throw 'handler-done nil)) Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/packages.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/packages.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,228 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/packages.lisp,v 1.33 2007/09/18 14:23:23 edi Exp $ + +;;; Copyright (c) 2004-2007, 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 :cl-user) + +(defpackage :hunchentoot-mp + (:nicknames :tbnl-mp) + (:use :cl) + (:export :*current-process* + :make-lock + :with-lock + :process-run-function + :process-kill)) + +(defpackage :hunchentoot + (:nicknames :tbnl) + (:use :cl :cl-ppcre :chunga :flexi-streams :url-rewrite :hunchentoot-mp) + (:shadow :assoc + #+:sbcl :defconstant + :handler-case + :ignore-errors + :url-encode) + ;; see ASDF system definition + (:import-from :hunchentoot-asd :*hunchentoot-version*) + #+:lispworks + (:import-from :lw :with-unique-names :when-let) + (:export :*approved-return-codes* + :*catch-errors-p* + :*cleanup-function* + :*cleanup-interval* + :*content-types-for-url-rewrite* + :*default-content-type* + :*default-handler* + :*default-log-level* + :*default-read-timeout* + :*default-write-timeout* + :*dispatch-table* + :*file-upload-hook* + :*handle-http-errors-p* + :*header-stream* + :*http-error-handler* + :*hunchentoot-default-external-format* + :*lisp-errors-log-level* + :*lisp-warnings-log-level* + :*listener* + :*log-lisp-backtraces-p* + :*log-lisp-errors-p* + :*log-lisp-warnings-p* + :*log-prefix* + :*meta-dispatcher* + :*methods-for-post-parameters* + :*reply* + :*request* + :*rewrite-for-session-urls* + :*server* + :*session* + :*session-cookie-name* + :*session-gc-frequency* + :*session-max-time* + :*session-removal-hook* + :*show-access-log-messages* + :*show-lisp-backtraces-p* + :*show-lisp-errors-p* + :*tmp-directory* + :*use-remote-addr-for-sessions* + :*use-user-agent-for-sessions* + :+http-accepted+ + :+http-authorization-required+ + :+http-bad-gateway+ + :+http-bad-request+ + :+http-conflict+ + :+http-continue+ + :+http-created+ + :+http-expectation-failed+ + :+http-failed-dependency+ + :+http-forbidden+ + :+http-gateway-time-out+ + :+http-gone+ + :+http-internal-server-error+ + :+http-length-required+ + :+http-method-not-allowed+ + :+http-moved-permanently+ + :+http-moved-temporarily+ + :+http-multiple-choices+ + :+http-multi-status+ + :+http-no-content+ + :+http-non-authoritative-information+ + :+http-not-acceptable+ + :+http-not-found+ + :+http-not-implemented+ + :+http-not-modified+ + :+http-ok+ + :+http-partial-content+ + :+http-payment-required+ + :+http-precondition-failed+ + :+http-proxy-authentication-required+ + :+http-request-entity-too-large+ + :+http-request-time-out+ + :+http-request-uri-too-large+ + :+http-requested-range-not-satisfiable+ + :+http-reset-content+ + :+http-see-other+ + :+http-service-unavailable+ + :+http-switching-protocols+ + :+http-temporary-redirect+ + :+http-unsupported-media-type+ + :+http-use-proxy+ + :+http-version-not-supported+ + :authorization + :aux-request-value + :content-length + :content-type + :cookie-domain + :cookie-expires + :cookie-http-only + :cookie-in + :cookie-name + :cookie-out + :cookie-path + :cookie-secure + :cookie-value + :cookies-in + :cookies-out + :create-folder-dispatcher-and-handler + :create-prefix-dispatcher + :create-regex-dispatcher + :create-static-file-dispatcher-and-handler + :default-dispatcher + :define-easy-handler + :delete-aux-request-value + :delete-session-value + :dispatch-easy-handlers + :dispatch-request + :do-sessions + :escape-for-html + :get-backtrace + :get-parameter + :get-parameters + :handle-if-modified-since + :handle-static-file + :handler-done + :header-in + :header-out + :headers-in + :headers-out + :host + :http-token-p + :log-file + :log-message + :log-message* + :maybe-invoke-debugger + :mime-type + :mod-lisp-id + :no-cache + :parameter + :post-parameter + :post-parameters + :query-string + :raw-post-data + :real-remote-addr + :reason-phrase + :recompute-request-parameters + :redirect + :referer + :remote-addr + :remote-port + :remove-session + :reply-external-format + :request-method + :request-uri + :require-authorization + :reset-sessions + :return-code + :rfc-1123-date + :script-name + :send-headers + :server-addr + :server-address + :server-dispatch-table + :server-local-port + :server-name + :server-port + :server-protocol + :session-counter + :session-gc + :session-max-time + :session-too-old-p + :session-remote-addr + :session-cookie-value + :session-user-agent + :session-value + :set-cookie + :set-cookie* + :ssl-p + :ssl-session-id + :start-server + :start-session + :stop-server + :url-decode + :url-encode + :user-agent)) + Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-acl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-acl.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,145 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/port-acl.lisp,v 1.10 2007/11/03 21:46:18 edi Exp $ + +;;; Copyright (c) 2004-2007, 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) + #-(and :allegro-version>= (version>= 7 0)) + (error "You need at least version 7.0 of AllegroCL.") + ;; make sure code for sockets and OS interface is loaded + (require :sock) + (require :osi)) + +(defun make-lock (name) + "See AllegroCL documentation for MP:MAKE-PROCESS-LOCK." + (mp:make-process-lock :name name)) + +(defmacro with-lock ((lock) &body body) + "See AllegroCL documentation for MP:WITH-PROCESS-LOCK." + `(mp:with-process-lock (,lock) ,@body)) + +(defmacro atomic-incf (place &optional (delta 1)) + "Like INCF but wrapped with SYS:WITHOUT-SCHEDULING so other +threads can't interfer." + `(sys:without-scheduling (incf ,place ,delta))) + +(defmacro with-timeout ((seconds &body timeout-forms) &body body) + "See AllegroCL documentation for SYS:WITH-TIMEOUT." + `(sys:with-timeout (,seconds ,@timeout-forms) ,@body)) + +(defun process-run-function (name function &rest args) + "See AllegroCL documentation for MP:PROCESS-RUN-FUNCTION." + (apply #'mp:process-run-function name function args)) + +(defun process-kill (process) + "See AllegroCL documentation for MP:PROCESS-KILL." + (mp:process-kill process)) + +(define-symbol-macro *current-process* + mp:*current-process*) + +(defun process-allow-scheduling () + "See AllegroCL documentation for MP:PROCESS-ALLOW-SCHEDULE." + (mp:process-allow-schedule)) + +(defun start-up-server (&key service address process-name announce function &allow-other-keys) + "Tries to \(partly) emulate LispWorks' COMM:START-UP-SERVER. See +<http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-56.htm> +for more info." + (let (done) + (flet ((open-socket-and-accept () + (handler-bind ((error (lambda (condition) + (funcall announce nil condition) + (setq done condition) + (return-from open-socket-and-accept)))) + (let (socket) + (unwind-protect + (progn + (setf socket (socket:make-socket :address-family :internet + :type :hiper + :format :bivalent + :connect :passive + :local-host address + :local-port service + :reuse-address t + :backlog 5)) + (funcall announce socket) + (setq done socket) + (loop (funcall function (socket:accept-connection socket :wait t)))) + (when socket + (cl:ignore-errors (close socket)))))))) + (let ((listener-thread (process-run-function process-name #'open-socket-and-accept))) + (mp:process-wait "Waiting for server to start" (lambda () done)) + (typecase done + (socket:socket listener-thread) + (t (values nil done))))))) + +(defun make-socket-stream (socket read-timeout write-timeout) + "Accepts a socket `handle' SOCKET and creates and returns a +corresponding stream, setting its read and write timeout if +applicable. Returns three other values - the address the request +arrived at, and the address and port of the remote host." + ;; in the case of AllegroCL, SOCKET:ACCEPT-CONNECTION already + ;; returned a stream + (socket:set-socket-options socket :nodelay t) + (socket:socket-control socket + :read-timeout read-timeout + :write-timeout write-timeout) + (values socket + (ignore-errors + (socket:ipaddr-to-dotted (socket:local-host socket))) + (ignore-errors + (socket:ipaddr-to-dotted (socket:remote-host socket))) + (ignore-errors + (socket:remote-port socket)))) + +(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)) + (cl:ignore-errors + (format *terminal-io* "~ +~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%" + error)) + (cl:ignore-errors + (let ((*terminal-io* s) + (*standard-output* s)) + (tpl:do-command "zoom" + :from-read-eval-print-loop nil + :count t + :all t))))))) + Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-clisp.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-clisp.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,131 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10; -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/port-clisp.lisp,v 1.1 2007/12/29 17:35:01 edi Exp $ + +;;; Copyright (c) 2006, Luis Ol�veira <loliveira(a)common-lisp.net>. +;;; Copyright (c) 2007, Anton Vodonosov <avodonosov(a)yandex.ru>. +;;; Copyright (c) 2007, 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 with-lock ((lock) &body body) + "Executes the BODY. LOCK is ignored because CLISP doesn't support +threads." + (declare (ignore lock)) + `(progn ,@body)) + +(defmacro atomic-incf (place &optional (delta 1)) + "Expands to INCF. No special semantics because CLISP doesn't support threads." + `(incf ,place ,delta)) + +(defmacro with-timeout ((seconds &body timeout-forms) &body body) + "Executes the code BODY and returns the results of the last form. +SECONDS and TIMEOUT-FORMS are ignored since CLISP doesn't support +threads." + (declare (ignore seconds timeout-forms)) + `(progn ,@body)) + +(defun make-lock (lock) + "CLISP doesn't support threads, so the function just returns its +argument LOCK." + lock) + +(defvar *current-process* "*CURRENT-PROCESS*" + "CLISP doesn't support threads, so this value is just a dummy stub.") + +(defun process-run-function (name function &rest args) + "In a multithreaded environment, this would run FUNCTION in a new +thread, but in CLISP we just apply FUNCTION to ARGS." + (declare (ignore name)) + (apply function args)) + +(defun process-allow-scheduling () + "Does nothing because CLISP doesn't support threads." + ) + +(defun process-kill (process) + "Does nothing because CLISP doesn't support threads." + (declare (ignore process)) + ) + +(defun start-up-server (&key service address process-name announce function &allow-other-keys) + "Tries to \(partly) emulate LispWorks' COMM:START-UP-SERVER. See +<http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-56.htm> +for more info." + (declare (ignore process-name)) + (cl:ignore-errors + (let ((socket (socket:socket-server service :interface address :backlog 5))) + (funcall announce socket) + (unwind-protect + (loop (funcall function + (socket:socket-accept socket + :buffered t + :element-type 'octet))) + (cl:ignore-errors + (socket:socket-server-close socket)))))) + +(defun make-socket-stream (socket read-timeout write-timeout) + "Accepts a socket `handle' HANDLE and creates and returns a +corresponding stream, setting its read and write timeout if +applicable. Returns three other values - the address the request +arrived at, and the address and port of the remote host." + (socket:socket-options socket + :SO-RCVTIMEO read-timeout + :SO-SNDTIMEO write-timeout) + (multiple-value-bind (remote-host remote-port) + (socket:socket-stream-peer socket) + (values socket + (nth-value 1 (socket:socket-stream-local socket)) + remote-host + remote-port))) + +;;; the following code is from swank-clisp.lisp (SLIME): + +(defun format-frame (frame) + "Returns a string describing the call stack frame object FRAME." + (string-trim #(#\Newline #\Space #\Tab) + (with-output-to-string (out) + (sys::describe-frame out frame)))) + +(defun function-frame-p (formatted-frame) + "Determines whether the frame described by FORMATTED-FRAME +is a function frame." + (char= #\< (aref formatted-frame 0))) + +(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) + (do ((last nil frame) + (frame (sys::the-frame) (sys::frame-up-1 frame 1))) + ((eq frame last)) + (let ((formatted-frame (format-frame frame))) + (when (function-frame-p formatted-frame) + (write-line (subseq formatted-frame (+ (position #\> formatted-frame) 2) + (position #\Newline formatted-frame)) + stream)))))) Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-cmu.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-cmu.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,137 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/port-cmu.lisp,v 1.10 2007/12/29 17:35:01 edi Exp $ + +;;; Copyright (c) 2004-2007, 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) + +#-:mp +(eval-when (:compile-toplevel :load-toplevel :execute) + (error "This library needs a version of CMUCL with MP support.")) + +(defun make-lock (name) + "See CMUCL documentation for MP:MAKE-LOCK." + (mp:make-lock name)) + +(defmacro with-lock ((lock) &body body) + "See CMUCL documentation for MP:WITH-LOCK-HELD." + `(mp:with-lock-held (,lock) ,@body)) + +(defmacro atomic-incf (place &optional (delta 1)) + "Like INCF but wrapped with MP:WITHOUT-SCHEDULING so other +threads can't interfer." + `(mp:without-scheduling (incf ,place ,delta))) + +(defmacro with-timeout ((seconds &body timeout-forms) &body body) + "See CMUCL documentation for MP:WITH-TIMEOUT." + `(mp:with-timeout (,seconds ,@timeout-forms) ,@body)) + +(defun process-run-function (name function &rest args) + "See CMUCL documentation for MP:MAKE-PROCESS." + (mp:make-process (lambda () + (apply function args)) + :name name)) + +(defun process-kill (process) + "See CMUCL documentation for MP:DESTROY-PROCESS." + (mp:destroy-process process)) + +(define-symbol-macro *current-process* + mp:*current-process*) + +(defun process-allow-scheduling () + "See CMUCL documentation for MP:PROCESS-YIELD." + (mp:process-yield)) + +(defun start-up-server (&key service address process-name announce function &allow-other-keys) + "Tries to \(partly) emulate LispWorks' COMM:START-UP-SERVER. See +<http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-56.htm> +for more info." + (let (done) + (flet ((open-socket-and-accept () + (handler-bind ((error (lambda (condition) + (funcall announce nil condition) + (setq done condition) + (return-from open-socket-and-accept)))) + (let (socket) + (unwind-protect + (progn + (setf socket (ext:create-inet-listener service :stream + :reuse-address t + :backlog 5 + :host (or address 0))) + (funcall announce socket) + (setq done socket) + (loop (funcall function (ext:accept-tcp-connection socket)))) + (when socket + (cl:ignore-errors + (ext:close-socket socket)))))))) + (let ((listener-thread (process-run-function process-name #'open-socket-and-accept))) + (mp:process-wait "Waiting for server to start" (lambda () done)) + (typecase done + (condition (values nil done)) + (t listener-thread)))))) + +(defun format-address (address) + "Converts an integer in network byte order denoting an IP +address into the corresponding string representation." + (format nil "~A.~A.~A.~A" + (ash address -24) + (logand (ash address -16) #xFF) + (logand (ash address -8) #xFF) + (logand address #xFF))) + +(defun make-socket-stream (handle read-timeout write-timeout) + "Accepts a socket `handle' HANDLE and creates and returns a +corresponding stream, setting its read and write timeout if +applicable. Returns three other values - the address the request +arrived at, and the address and port of the remote host." + (declare (ignore write-timeout)) + (let ((local-host (ext:get-socket-host-and-port handle))) + (multiple-value-bind (remote-host remote-port) + (ext:get-peer-host-and-port handle) + (values (sys:make-fd-stream handle + :input t :output t + :element-type 'octet + :auto-close t + :buffering :full + :timeout read-timeout + :name (format nil "~A:~A" (format-address remote-host) remote-port)) + (format-address local-host) + (format-address remote-host) + remote-port)))) + +(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)))) + Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-lw.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-lw.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,173 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/port-lw.lisp,v 1.12 2007/12/29 17:35:01 edi Exp $ + +;;; Copyright (c) 2004-2007, 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) + +#+(and :lispworks4.4 (or :win32 :linux)) +(let ((id :system-cons-free-chain)) + (unless (scm::patch-id-loaded-p id) + (error "You need a patch to improve the performance of this code. Request patch ~S for ~A for ~A from lisp-support(a)lispworks.com using the Report Bug command." + id (lisp-implementation-type) + #+:win32 "Windows" + #+:linux "Linux"))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; make sure socket code is loaded + (require "comm")) + +(defun make-lock (name) + "See LispWorks documentation for MP:MAKE-LOCK." + (mp:make-lock :name name)) + +(defmacro with-lock ((lock) &body body) + "See LispWorks documentation for MP:WITH-LOCK." + `(mp:with-lock (,lock) ,@body)) + +(defmacro atomic-incf (place &optional (delta 1)) + "Like INCF but wrapped with MP:WITHOUT-PREEMPTION so other +threads can't interfer." + `(mp:without-preemption (incf ,place ,delta))) + +(defun invoke-with-timeout (duration body-fn timeout-fn) + "Executes the function \(with no arguments) BODY-FN and returns +its results but stops execution after DURATION seconds and then +instead calls TIMEOUT-FN and returns its values." + ;; from Portable AllegroServe + (block timeout + (let* ((process mp:*current-process*) + (unsheduledp nil) + (timer (mp:make-timer + #'(lambda () + (mp:process-interrupt process + #'(lambda () + (unless unsheduledp + (return-from timeout + (funcall timeout-fn))))))))) + (mp:schedule-timer-relative timer duration) + (unwind-protect + (funcall body-fn) + (mp:without-interrupts + (mp:unschedule-timer timer) + (setf unsheduledp t)))))) + +(defmacro with-timeout ((seconds &body timeout-forms) &body body) + "Executes the code BODY and returns the results of the last +form but stops execution after SECONDS seconds and then instead +executes the code in TIMEOUT-FORMS." + ;; from Portable AllegroServe + `(invoke-with-timeout ,seconds + #'(lambda () + ,@body) + #'(lambda () + ,@timeout-forms))) + +(defun process-run-function (name function &rest args) + "See LispWorks documentation for MP:PROCESS-RUN-FUNCTION." + (apply #'mp:process-run-function name nil function args)) + +(defun process-kill (process) + "See LispWorks documentation for MP:PROCESS-KILL." + (mp:process-kill process)) + +(define-symbol-macro *current-process* + mp:*current-process*) + +(defun process-allow-scheduling () + "See LispWorks documentation for MP:PROCESS-ALLOW-SCHEDULING." + (mp:process-allow-scheduling)) + +(defun start-up-server (&rest args) + "See LispWorks documentation for COMM:START-UP-SERVER." + (apply #'comm:start-up-server args)) + +(defun make-socket-stream (socket read-timeout write-timeout) + "Accepts a socket `handle' SOCKET and creates and returns a +corresponding stream, setting its read and write timeout if +applicable. Returns three other values - the address the request +arrived at, and the address and port of the remote host." + #-:lispworks5 (declare (ignore write-timeout)) + (let ((local-host (comm:get-socket-address socket))) + (multiple-value-bind (remote-host remote-port) + (comm:get-socket-peer-address socket) + (values (make-instance 'comm:socket-stream + :socket socket + :direction :io + :read-timeout read-timeout + #+:lispworks5 #+:lispworks5 + :write-timeout write-timeout + :element-type 'octet) + (ignore-errors + (comm:ip-address-string local-host)) + (ignore-errors + (comm:ip-address-string remote-host)) + remote-port)))) + +#-:hunchentoot-no-ssl +(defun make-ssl-server-stream (socket-stream &key certificate-file privatekey-file privatekey-password) + "Given the server socket stream SOCKET-STREAM attaches SSL to the +stream using the certificate file CERTIFICATE-FILE and the private key +file PRIVATEKEY-FILE. Both of these values must be namestrings +denoting the location of the files. If PRIVATEKEY-PASSWORD is not NIL +then it should be the password for the private key file \(if +necessary)." + (flet ((ctx-configure-callback (ctx) + (when privatekey-password + (comm:set-ssl-ctx-password-callback ctx :password privatekey-password)) + (comm:ssl-ctx-use-certificate-file ctx + certificate-file + comm:ssl_filetype_pem) + (comm:ssl-ctx-use-privatekey-file ctx + privatekey-file + comm:ssl_filetype_pem))) + (comm:attach-ssl socket-stream + :ctx-configure-callback #'ctx-configure-callback))) + +(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)))) + +;; some help for the IDE +(dspec:define-dspec-alias defvar-unbound (name) + `(defparameter ,name)) + +(dspec:define-dspec-alias def-http-return-code (name) + `(defconstant ,name)) + +(editor:setup-indent "defvar-unbound" 1 2 4) + +(editor:setup-indent "def-http-return-code" 1 2 4) + Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-mcl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-mcl.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,136 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/port-mcl.lisp,v 1.9 2007/11/03 21:46:19 edi Exp $ + +;;; Copyright (c) 2004-2007, 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 make-lock (name) + "See OpenMCL documentation for CCL:MAKE-LOCK." + (ccl:make-lock name)) + +(defmacro with-lock ((lock) &body body) + "See OpenMCL documentation for CCL:WITH-LOCK-GRABBED." + `(ccl:with-lock-grabbed (,lock) ,@body)) + +(defmacro atomic-incf (place &optional (delta 1)) + "Like INCF, but other threads can't interfer." + `(ccl::atomic-incf-decf ,place ,delta)) + +(defun invoke-with-timeout (seconds bodyfn timeoutfn) + "Executes the function \(with no arguments) BODY-FN and returns +its results but stops execution after DURATION seconds and then +instead calls TIMEOUT-FN and returns its values." + ;; from Portable AllegroServe + (block timeout + (let* ((timer (ccl::make-timer-request seconds + #'(lambda () + (return-from timeout (funcall timeoutfn)))))) + (ccl::enqueue-timer-request timer) + (unwind-protect (funcall bodyfn) + (ccl::dequeue-timer-request timer))))) + +(defmacro with-timeout ((seconds &body timeout-forms) &body body) + "Executes the code BODY and returns the results of the last +form but stops execution after SECONDS seconds and then instead +executes the code in TIMEOUT-FORMS." + ;; from Portable AllegroServe + `(invoke-with-timeout ,seconds + #'(lambda () ,@body) + #'(lambda () ,@timeout-forms))) + +(defun process-run-function (name function &rest args) + "See OpenMCL documentation for CCL:PROCESS-RUN-FUNCTION." + (apply #'ccl:process-run-function name function args)) + +(defun process-kill (process) + "See OpenMCL documentation for CCL:PROCESS-KILL." + (ccl:process-kill process)) + +(define-symbol-macro *current-process* + ccl:*current-process*) + +(defun process-allow-scheduling () + "See OpenMCL documentation for CCL:PROCESS-ALLOW-SCHEDULE" + (ccl:process-allow-schedule)) + +(defun start-up-server (&key service address process-name announce function &allow-other-keys) + "Tries to \(partly) emulate LispWorks' COMM:START-UP-SERVER. See +<http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-56.htm> +for more info." + (let (done) + (flet ((open-socket-and-accept () + (handler-bind ((error (lambda (condition) + (funcall announce nil condition) + (setq done condition) + (return-from open-socket-and-accept)))) + (let (socket) + (unwind-protect + (progn + (setf socket (ccl:make-socket :address-family :internet + :type :stream + :connect :passive + :local-host address + :local-port service + :reuse-address t + :backlog 5)) + (funcall announce socket) + (setq done socket) + (loop (funcall function (ccl:accept-connection socket :wait t)))) + (when socket + (cl:ignore-errors + (close socket)))))))) + (let ((listener-thread (process-run-function process-name #'open-socket-and-accept))) + (ccl:process-wait "Waiting for server to start" (lambda () done)) + (typecase done + (condition (values nil done)) + (t listener-thread)))))) + +(defun make-socket-stream (socket read-timeout write-timeout) + "Accepts a socket `handle' SOCKET and creates and returns a +corresponding stream, setting its read and write timeout if +applicable. Returns three other values - the address the request +arrived at, and the address and port of the remote host." + (declare (ignore read-timeout write-timeout)) + (values socket + (ignore-errors + (ccl:ipaddr-to-dotted (ccl:local-host socket))) + (ignore-errors + (ccl:ipaddr-to-dotted (ccl:remote-host socket))) + (ignore-errors + (ccl:remote-port socket)))) + +(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)))) Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-sbcl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-sbcl.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,205 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/port-sbcl.lisp,v 1.13 2007/12/29 17:35:01 edi Exp $ + +;;; Copyright (c) 2004-2007, 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) + +#-:sb-unicode +(eval-when (:compile-toplevel :load-toplevel :execute) + (error "This library needs a version of SBCL with Unicode support.")) + +#-:sb-thread +(eval-when (:compile-toplevel :load-toplevel :execute) + (warn "Without thread support, this library is only useful for development.")) + +(defmacro defconstant (name value &optional doc) + "Make sure VALUE is evaluated only once \(to appease SBCL)." + `(cl:defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value) + ,@(when doc (list doc)))) + +(defun make-lock (name) + "See SBCL documentation for SB-THREAD:MAKE-MUTEX." + (sb-thread:make-mutex :name name)) + +(defmacro with-lock ((lock) &body body) + "See SBCL documentation for SB-THREAD:WITH-RECURSIVE-LOCK." + `(sb-thread:with-recursive-lock (,lock) ,@body)) + +(defvar *incf-mutex* (sb-thread:make-mutex :name "incf-mutex") + "The mutex used for ATOMIC-INCF.") + +(defmacro atomic-incf (place &optional (delta 1)) + "Like INCF but protected by a mutex, so other threads can't +interfer." + `(with-lock (*incf-mutex*) (incf ,place ,delta))) + +;; determine whether SB-EXT:WITH-TIMEOUT is supported; we can't just +;; use (FIND-SYMBOL "WITH-TIMEOUT" "SB-EXT") because sometimes (for +;; example in SBCL 1.0.6 for Win32) the function is present, but +;; doesn't work +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun ensured-sleep-millis (milliseconds) + "Sleeps \(in fact loops) not less then MILLISECONDS number of +milliseconds; the minimal sleep time is one internal time unit. Don't +use this function for large time values, because it eats processor +power." + (do ((start-time (get-internal-real-time))) + ((< (+ start-time (ceiling (* internal-time-units-per-second + (/ milliseconds 1000)))) + (get-internal-real-time))))) + (cl:handler-case + (sb-ext:with-timeout 0.0000001 (ensured-sleep-millis 5)) + (sb-ext:timeout () + (pushnew :hunchentoot-sbcl-with-timeout *features*)) + (t ()))) + +(defmacro with-timeout ((seconds &body timeout-forms) &body body) + "Executes the code BODY and returns the results of the last +form but stops execution after SECONDS seconds and then instead +executes the code in TIMEOUT-FORMS." + (declare (ignorable seconds timeout-forms body)) + #-:hunchentoot-sbcl-with-timeout `(cl:progn ,@body) + #+:hunchentoot-sbcl-with-timeout + `(cl:handler-case + (sb-ext:with-timeout ,seconds ,@body) + (sb-ext:timeout () ,@timeout-forms))) + +(defun process-run-function (name function &rest args) + "See SBCL documentation for SB-THREAD:MAKE-THREAD." + (declare (ignorable name)) + #+:sb-thread + (sb-thread:make-thread (lambda () + (apply function args)) + :name name) + #-:sb-thread + (apply function args)) + +(defun process-kill (process) + "See SBCL documentation for SB-THREAD:TERMINATE-THREAD." + (sb-thread:terminate-thread process)) + +(define-symbol-macro *current-process* + sb-thread:*current-thread*) + +(defun process-allow-scheduling () + "Used to simulate a function like PROCESS-ALLOW-SCHEDULING +which can be found in most other Lisps." + (sleep .1)) + +(defun resolve-hostname (name) + "Converts from different types to represent an IP address to +the canonical representation which is an array with four +integers." + (typecase name + (null #(0 0 0 0)) + (string (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name name)))) + (integer (make-array 4 :initial-contents (list (ash name -24) + (logand (ash name -16) #xFF) + (logand (ash name -8) #xFF) + (logand name #xFF)))) + (t name))) + +(defun start-up-server (&key service address process-name announce function &allow-other-keys) + "Tries to \(partly) emulate LispWorks' COMM:START-UP-SERVER. See +<http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-56.htm> +for more info." + (let (done) + (flet ((open-socket-and-accept () + (handler-bind ((error (lambda (condition) + (funcall announce nil condition) + (setq done condition) + (return-from open-socket-and-accept)))) + (let (socket) + (unwind-protect + (progn + (setf socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp) + (sb-bsd-sockets:sockopt-reuse-address socket) t) + (sb-bsd-sockets:socket-bind socket (resolve-hostname address) service) + (sb-bsd-sockets:socket-listen socket 5) + (funcall announce socket) + (setq done socket) + (loop (funcall function (sb-bsd-sockets:socket-accept socket)))) + (when socket + (cl:ignore-errors + (sb-bsd-sockets:socket-close socket)))))))) + (let ((listener-thread (process-run-function process-name #'open-socket-and-accept))) + (loop until done do (sleep .1)) + (typecase done + (sb-bsd-sockets:inet-socket listener-thread) + (t (values nil done))))))) + +(defun format-address (address) + "Converts an array of four integers denoting an IP address into +the corresponding string representation." + (format nil "~{~A~^.~}" (coerce address 'list))) + +(defun make-socket-stream (socket read-timeout write-timeout) + "Accepts a socket `handle' SOCKET and creates and returns a +corresponding stream, setting its read and write timeout if +applicable. Returns three other values - the address the request +arrived at, and the address and port of the remote host." + (declare (ignore write-timeout)) + (let ((local-host (sb-bsd-sockets:socket-name socket))) + (multiple-value-bind (remote-host remote-port) + (sb-bsd-sockets:socket-peername socket) + (values (sb-bsd-sockets:socket-make-stream socket + :input t + :output t + :element-type 'octet + :timeout read-timeout + :buffering :full) + (format-address local-host) + (format-address remote-host) + remote-port)))) + +;; determine how we're going to access the backtrace in the next +;; function +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (find-symbol "*DEBUG-PRINT-VARIABLE-ALIST*" :sb-debug) + (pushnew :hunchentoot-sbcl-debug-print-variable-alist *features*))) + +(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)))) + Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/reply.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/reply.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,144 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/reply.lisp,v 1.19 2007/09/24 13:43:45 edi Exp $ + +;;; Copyright (c) 2004-2007, 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 reply () + ((content-type :initform *default-content-type* + :documentation "The outgoing 'Content-Type' http +header which defaults to the value of *DEFAULT-CONTENT-TYPE*.") + (content-length :initform nil + :documentation "The outgoing 'Content-Length' +http header which defaults NIL. If this is NIL, Hunchentoot will +compute the content length.") + (headers-out :initform nil + :documentation "An alist of the outgoing http headers +not including the 'Set-Cookie', 'Content-Length', and 'Content-Type' +headers. Use the functions HEADER-OUT and \(SETF HEADER-OUT) to +modify this slot.") + (return-code :initform +http-ok+ + :documentation "The http return code of this +reply. The return codes Hunchentoot can handle are defined in +specials.lisp.") + (external-format :initform *hunchentoot-default-external-format* + :documentation "The external format of the reply - +used for character output.") + (log-messages :initform nil + :reader log-messages + :documentation "A list \(in reverse chronological +order) of the messages which are to be written to the Apache error +log. This slot's value should only be modified by the functions +defined in log.lisp.") + (cookies-out :initform nil + :documentation "The outgoing cookies. This slot's +value should only be modified by the functions defined in +cookies.lisp.")) + (:documentation "Objects of this class hold all the information +about an outgoing reply. They are created automatically by +Hunchentoot and can be accessed and modified by the corresponding +handler.")) + +(defun headers-out (&optional (reply *reply*)) + "Returns an alist of the outgoing headers associated with the +REPLY object REPLY." + (slot-value reply 'headers-out)) + +(defun cookies-out (&optional (reply *reply*)) + "Returns an alist of the outgoing cookies associated with the +REPLY object REPLY." + (slot-value reply 'cookies-out)) + +(defun (setf cookies-out) (new-value &optional (reply *reply*)) + "Returns an alist of the outgoing cookies associated with the +REPLY object REPLY." + (setf (slot-value reply 'cookies-out) new-value)) + +(defun content-type (&optional (reply *reply*)) + "The outgoing 'Content-Type' http header of REPLY." + (slot-value reply 'content-type)) + +(defun (setf content-type) (new-value &optional (reply *reply*)) + "Sets the outgoing 'Content-Type' http header of REPLY." + (setf (slot-value reply 'content-type) new-value)) + +(defun content-length (&optional (reply *reply*)) + "The outgoing 'Content-Length' http header of REPLY." + (slot-value reply 'content-length)) + +(defun (setf content-length) (new-value &optional (reply *reply*)) + "Sets the outgoing 'Content-Length' http header of REPLY." + (setf (slot-value reply 'content-length) new-value)) + +(defun return-code (&optional (reply *reply*)) + "The http return code of REPLY. The return codes Hunchentoot can +handle are defined in specials.lisp." + (slot-value reply 'return-code)) + +(defun (setf return-code) (new-value &optional (reply *reply*)) + "Sets the http return code of REPLY." + (setf (slot-value reply 'return-code) new-value)) + +(defun reply-external-format (&optional (reply *reply*)) + "The external format of REPLY which is used for character output." + (slot-value reply 'external-format)) + +(defun (setf reply-external-format) (new-value &optional (reply *reply*)) + "Sets the external format of REPLY." + (setf (slot-value reply 'external-format) new-value)) + +(defun header-out-set-p (name &optional (reply *reply*)) + "Returns a true value if the outgoing http header named NAME has +been specified already. NAME should be a keyword or a string." + (assoc name (headers-out reply))) + +(defun header-out (name &optional (reply *reply*)) + "Returns the current value of the outgoing http header named NAME. +NAME should be a keyword or a string." + (cdr (assoc name (headers-out reply)))) + +(defun cookie-out (name &optional (reply *reply*)) + "Returns the current value of the outgoing cookie named +NAME. Search is case-sensitive." + (cdr (assoc name (cookies-out reply) :test #'string=))) + +(defsetf header-out (name &optional (reply '*reply*)) + (new-value) + "Changes the current value of the outgoing http header named NAME (a +keyword or a string). If a header with this name doesn't exist, it is +created." + (with-rebinding (name reply) + (with-unique-names (symbol place) + `(let* ((,symbol (if (stringp ,name) (make-keyword ,name :destructivep nil) ,name)) + (,place (assoc ,symbol (headers-out ,reply) :test #'string-equal))) + (cond + (,place + (setf (cdr ,place) ,new-value)) + (t + (push (cons ,symbol ,new-value) (slot-value ,reply 'headers-out)) + ,new-value)))))) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/request.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/request.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,475 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/request.lisp,v 1.34 2007/12/29 17:35:01 edi Exp $ + +;;; Copyright (c) 2004-2007, 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 request () + ((headers-in :initarg :headers-in + :documentation "An alist of the incoming headers. Note +that these might be the headers coming in from mod_lisp which are +different from the headers sent by the client.") + (method :initarg :method + :documentation "The request method as a keyword. This slot +is only filled if we're not behind mod_lisp.") + (uri :initarg :uri + :documentation "The request URI as a string. This slot is +only filled if we're not behind mod_lisp.") + (server-protocol :initarg :server-protocol + :documentation "The HTTP protocol as a keyword. +This slot is only filled if we're not behind mod_lisp.") + (content-stream :initarg :content-stream + :reader content-stream + :documentation "A stream from which the request +body can be read if there is one.") + (cookies-in :initform nil + :documentation "An alist of the cookies sent by the client.") + (get-parameters :initform nil + :documentation "An alist of the GET parameters sent +by the client.") + (post-parameters :initform nil + :documentation "An alist of the POST parameters +sent by the client.") + (script-name :initform nil + :documentation "The URI requested by the client without +the query string.") + (query-string :initform nil + :documentation "The query string of this request.") + (session :initform nil + :accessor session + :documentation "The session object associated with this +request.") + (aux-data :initform nil + :accessor aux-data + :documentation "Used to keep a user-modifiable alist with +arbitrary data during the request.") + (raw-post-data :initform nil + :documentation "The raw string sent as the body of a +POST request, populated only if not a multipart/form-data request.")) + (:documentation "Objects of this class hold all the information +about an incoming request. They are created automatically by +Hunchentoot and can be accessed by the corresponding handler.")) + +(defun parse-rfc2388-form-data (stream content-type-header) + "Creates an alist of POST parameters from the stream STREAM which is +supposed to be of content type 'multipart/form-data'." + (let* ((parsed-content-type-header (rfc2388:parse-header content-type-header :value)) + (boundary (or (cdr (rfc2388:find-parameter + "BOUNDARY" + (rfc2388:header-parameters parsed-content-type-header))) + (return-from parse-rfc2388-form-data)))) + (loop for part in (rfc2388:parse-mime stream boundary) + for headers = (rfc2388:mime-part-headers part) + for content-disposition-header = (rfc2388:find-content-disposition-header headers) + for name = (cdr (rfc2388:find-parameter + "NAME" + (rfc2388:header-parameters content-disposition-header))) + when name + collect (cons name + (let ((contents (rfc2388:mime-part-contents part))) + (if (pathnamep contents) + (list contents + (rfc2388:get-file-name headers) + (rfc2388:content-type part :as-string t)) + contents)))))) + +(defun get-post-data (&key (request *request*) want-stream (already-read 0)) + "Reads the request body from the stream and stores the raw contents +\(as an array of octets) in the corresponding slot of the REQUEST +object. Returns just the stream if WANT-STREAM is true. If there's a +Content-Length header, it is assumed, that ALREADY-READ octets have +already been read." + (let* ((headers-in (headers-in request)) + (content-length (when-let (content-length-header (cdr (assoc :content-length headers-in))) + (parse-integer content-length-header :junk-allowed t))) + (content-stream (content-stream request))) + (setf (slot-value request 'raw-post-data) + (cond (want-stream + (setf (flexi-stream-position *hunchentoot-stream*) 0) + (when content-length + (setf (flexi-stream-bound content-stream) content-length)) + content-stream) + ((and content-length (> content-length already-read)) + (decf content-length already-read) + (when (input-chunking-p) + ;; see RFC 2616, section 4.4 + (log-message :warn "Got Content-Length header although input chunking is on.")) + (let ((content (make-array content-length :element-type 'octet))) + #+:clisp (setf (flexi-stream-element-type content-stream) 'octet) + (read-sequence content content-stream) + content)) + ((input-chunking-p) + (loop with buffer = (make-array +buffer-length+ :element-type 'octet) + with content = (make-array 0 :element-type 'octet :adjustable t) + for index = 0 then (+ index pos) + for pos = (read-sequence buffer content-stream) + do (adjust-array content (+ index pos)) + (replace content buffer :start1 index :end2 pos) + while (= pos +buffer-length+) + finally (return content))))))) + +(defmethod initialize-instance :after ((request request) &rest init-args) + "The only initarg for a REQUEST object is :HEADERS-IN. All other +slot values are computed in this :AFTER method." + (declare (ignore init-args)) + (with-slots (headers-in cookies-in get-parameters post-parameters script-name query-string session) + request + (handler-case + (progn + (when (server-mod-lisp-p *server*) + ;; convert these two values to keywords + (let ((method-pair (assoc :method headers-in))) + (setf (cdr method-pair) (make-keyword (cdr method-pair)))) + (let ((protocol-pair (assoc :server-protocol headers-in))) + (setf (cdr protocol-pair) (make-keyword (cdr protocol-pair)))) + ;; and convert these two values to integers + (let ((remote-ip-port-pair (assoc :remote-ip-port headers-in))) + (setf (cdr remote-ip-port-pair) (parse-integer (cdr remote-ip-port-pair) + :junk-allowed t))) + (let ((server-ip-port-pair (assoc :server-ip-port headers-in))) + (setf (cdr server-ip-port-pair) (parse-integer (cdr server-ip-port-pair) + :junk-allowed t)))) + ;; compute SCRIPT-NAME and QUERY-STRING slots from + ;; REQUEST_URI environment variable + (let* ((uri (request-uri request)) + (match-start (position #\? uri))) + (cond + (match-start + (setq script-name (subseq uri 0 match-start) + query-string (subseq uri (1+ match-start)))) + (t (setq script-name uri)))) + ;; some clients (e.g. ASDF-INSTALL) send requests like + ;; "GET http://server/foo.html HTTP/1.0"... + (setq script-name (regex-replace "^https?://[^/]+" script-name "")) + ;; compute GET parameters from query string and cookies from + ;; the incoming 'Cookie' header + (setq get-parameters + (form-url-encoded-list-to-alist (split "&" query-string)) + cookies-in + (form-url-encoded-list-to-alist (split "\\s*[,;]\\s*" (cdr (assoc :cookie headers-in))) + +utf-8+) + session (session-verify request) + *session* session) + ;; if the content-type is 'application/x-www-form-urlencoded' + ;; or 'multipart/form-data', compute the post parameters from + ;; the content body + (when (member (request-method request) *methods-for-post-parameters* :test #'eq) + (when-let (content-type (cdr (assoc :content-type headers-in))) + (multiple-value-bind (type subtype external-format) + (parse-content-type content-type t) + (setq post-parameters + (cond ((and (string-equal type "application") + (string-equal subtype "x-www-form-urlencoded")) + (unless (or (assoc :content-length headers-in) + (input-chunking-p)) + (error "Can't read request body because there's no~ +Content-Length header and input chunking is off.")) + (form-url-encoded-list-to-alist + (split "&" (raw-post-data :request request + ;; ASCII would suffice according to RFC... + :external-format +latin-1+)) + external-format)) + ((and (string-equal type "multipart") + (string-equal subtype "form-data")) + (setf (slot-value request 'raw-post-data) t) + (handler-case + (let* ((*request* request) + (content-stream (content-stream request)) + (start (flexi-stream-position content-stream))) + (prog1 + (parse-rfc2388-form-data content-stream content-type) + (let* ((end (flexi-stream-position content-stream)) + (stray-data (get-post-data :already-read (- end start)))) + (when (and stray-data (plusp (length stray-data))) + (warn "~A octets of stray data after form-data sent by client." + (length stray-data)))) + (setf (slot-value request 'raw-post-data) t))) + (error (msg) + (log-message :error + "While parsing multipart/form-data parameters: ~A" + msg) + nil))))))))) + (error (cond) + (log-message* "Error when creating REQUEST object: ~A" cond) + ;; we assume it's not our fault... + (setf (return-code) +http-bad-request+))))) + +(defun recompute-request-parameters (&key (request *request*) + (external-format *hunchentoot-default-external-format*)) + "Recomputes the GET and POST parameters for the REQUEST object +REQUEST. This only makes sense if you're switching external formats +during the request." + (with-slots (headers-in get-parameters post-parameters query-string) + request + (setq get-parameters + (form-url-encoded-list-to-alist (split "&" query-string) external-format) + post-parameters + (when-let (raw-post-data (raw-post-data :request request + :external-format +latin-1+)) + (and (when-let (content-type (cdr (assoc :content-type headers-in))) + (multiple-value-bind (type subtype) + (parse-content-type content-type) + (and (string-equal type "application") + (string-equal subtype "x-www-form-urlencoded")))) + (form-url-encoded-list-to-alist (split "&" raw-post-data) external-format))))) + (values)) + +(defun script-name (&optional (request *request*)) + "Returns the file name of the REQUEST object REQUEST. That's the +requested URI without the query string \(i.e the GET parameters)." + (slot-value request 'script-name)) + +(defun query-string (&optional (request *request*)) + "Returns the query string of the REQUEST object REQUEST. That's +the part behind the question mark \(i.e. the GET parameters)." + (slot-value request 'query-string)) + +(defun get-parameters (&optional (request *request*)) + "Returns an alist of the GET parameters associated with the REQUEST +object REQUEST." + (slot-value request 'get-parameters)) + +(defun post-parameters (&optional (request *request*)) + "Returns an alist of the POST parameters associated with the REQUEST +object REQUEST." + (slot-value request 'post-parameters)) + +(defun headers-in (&optional (request *request*)) + "Returns an alist of the incoming headers associated with the +REQUEST object REQUEST." + (slot-value request 'headers-in)) + +(defun cookies-in (&optional (request *request*)) + "Returns an alist of all cookies associated with the REQUEST object +REQUEST." + (slot-value request 'cookies-in)) + +(defun header-in (name &optional (request *request*)) + "Returns the incoming header with name NAME. NAME can be a keyword +\(recommended) or a string." + (cdr (assoc name (headers-in request)))) + +(defun authorization (&optional (request *request*)) + "Returns as two values the user and password \(if any) as encoded in +the 'AUTHORIZATION' header. Returns NIL if there is no such header." + (let* ((authorization (header-in :authorization request)) + (start (and authorization + (> (length authorization) 5) + (string-equal "Basic" authorization :end2 5) + (scan "\\S" authorization :start 5)))) + (when start + (destructuring-bind (&optional user password) + (split ":" (base64:base64-string-to-string (subseq authorization start))) + (values user password))))) + +(defun remote-addr (&optional (request *request*)) + "Returns the address the current request originated from." + (cond ((server-mod-lisp-p *server*) (header-in :remote-ip-addr request)) + (t *remote-host*))) + +(defun real-remote-addr (&optional (request *request*)) + "Returns the 'X-Forwarded-For' incoming http header as the +second value in the form of a list of IP addresses and the first +element of this list as the first value if this header exists. +Otherwise returns the value of REMOTE-ADDR as the only value." + (let ((x-forwarded-for (header-in :x-forwarded-for request))) + (cond (x-forwarded-for (let ((addresses (split "\\s*,\\s*" x-forwarded-for))) + (values (first addresses) addresses))) + (t (remote-addr request))))) + +(defun server-addr (&optional (request *request*)) + "Returns the address at which the current request arrived." + (cond ((server-mod-lisp-p *server*) (header-in :server-ip-addr request)) + (t *local-host*))) + +(defun remote-port (&optional (request *request*)) + "Returns the port the current request originated from." + (cond ((server-mod-lisp-p *server*) (header-in :remote-ip-port request)) + (t *remote-port*))) + +(defun server-port (&optional (request *request*)) + "Returns the port at which the current request arrived." + (cond ((server-mod-lisp-p *server*) (header-in :server-ip-port request)) + (t (server-local-port *server*)))) + +(defun host (&optional (request *request*)) + "Returns the 'Host' incoming http header value." + (header-in :host request)) + +(defun request-uri (&optional (request *request*)) + "Returns the request URI." + (cond ((server-mod-lisp-p *server*) (header-in :url request)) + (t (slot-value request 'uri)))) + +(defun request-method (&optional (request *request*)) + "Returns the request method as a Lisp keyword." + (cond ((server-mod-lisp-p *server*) (header-in :method request)) + (t (slot-value request 'method)))) + +(defun server-protocol (&optional (request *request*)) + "Returns the request protocol as a Lisp keyword." + (cond ((server-mod-lisp-p *server*) (header-in :server-protocol request)) + (t (slot-value request 'server-protocol)))) + +(defun mod-lisp-id (&optional (request *request*)) + "Returns the 'Server ID' sent by mod_lisp. This value is set in +Apache's server configuration file and is of course only available if +mod_lisp is the front-end." + (and (or (server-mod-lisp-p *server*) + (warn "Calling MOD-LISP-ID although ~S is a stand-alone server." + *server*)) + (header-in :server-id request))) + +(defun ssl-session-id (&optional (request *request*)) + "Returns the 'SSL_SESSION_ID' header sent my mod_lisp and is of +course only available if mod_lisp is the front-end." + (and (or (server-mod-lisp-p *server*) + (warn "Calling SSL-SESSION-ID although ~S is a stand-alone server." + *server*)) + (header-in :ssl-session-id request))) + +(defun user-agent (&optional (request *request*)) + "Returns the 'User-Agent' http header." + (header-in :user-agent request)) + +(defun cookie-in (name &optional (request *request*)) + "Returns the cookie with the name NAME \(a string) as sent by the +browser - or NIL if there is none." + (cdr (assoc name (cookies-in request) :test #'string=))) + +(defun referer (&optional (request *request*)) + "Returns the 'Referer' \(sic!) http header." + (header-in :referer request)) + +(defun get-parameter (name &optional (request *request*)) + "Returns the GET parameter with name NAME \(a string) - or NIL if +there is none. Search is case-sensitive." + (cdr (assoc name (get-parameters request) :test #'string=))) + +(defun post-parameter (name &optional (request *request*)) + "Returns the POST parameter with name NAME \(a string) - or NIL if +there is none. Search is case-sensitive." + (cdr (assoc name (post-parameters request) :test #'string=))) + +(defun parameter (name &optional (request *request*)) + "Returns the GET or the POST parameter with name NAME \(a string) - +or NIL if there is none. If both a GET and a POST parameter with the +same name exist the GET parameter is returned. Search is +case-sensitive." + (or (get-parameter name request) + (post-parameter name request))) + +(defun handle-if-modified-since (time &optional (request *request*)) + "Handles the 'If-Modified-Since' header of REQUEST. The date string +is compared to the one generated from the supplied universal time +TIME." + (let ((if-modified-since (header-in :if-modified-since request)) + (time-string (rfc-1123-date time))) + ;; simple string comparison is sufficient; see RFC 2616 14.25 + (when (and if-modified-since + (equal if-modified-since time-string)) + (setf (return-code) +http-not-modified+) + (throw 'handler-done nil)) + (values))) + +(defun raw-post-data (&key (request *request*) external-format force-binary force-text want-stream) + "Returns the content sent by the client if there was any \(unless +the content type was \"multipart/form-data\"). By default, the result +is a string if the type of the `Content-Type' media type is \"text\", +and a vector of octets otherwise. In the case of a string, the +external format to be used to decode the content will be determined +from the `charset' parameter sent by the client \(or otherwise +*HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT* will be used). + +You can also provide an external format explicitly \(through +EXTERNAL-FORMAT) in which case the result will unconditionally be a +string. Likewise, you can provide a true value for FORCE-TEXT which +will force Hunchentoot to act as if the type of the media type had +been \"text\". Or you can provide a true value for FORCE-BINARY which +means that you want a vector of octets at any rate. + +If, however, you provide a true value for WANT-STREAM, the other +parameters are ignored and you'll get the content \(flexi) stream to +read from it yourself. It is then your responsibility to read the +correct amount of data, because otherwise you won't be able to return +a response to the client. If the content type of the request was +`multipart/form-data' or `application/x-www-form-urlencoded', the +content has been read by Hunchentoot already and you can't read from +the stream anymore. + +You can call RAW-POST-DATA more than once per request, but you can't +mix calls which have different values for WANT-STREAM. + +Note that this function is slightly misnamed because a client can send +content even if the request method is not POST." + (when (and force-binary force-text) + (error "It doesn't make sense to set both FORCE-BINARY and FORCE-TEXT to a true value.")) + (unless (or external-format force-binary) + (setq external-format + (when-let (content-type (cdr (assoc :content-type (headers-in request)))) + (nth-value 2 (parse-content-type content-type force-text))))) + (let ((raw-post-data (or (slot-value request 'raw-post-data) + (get-post-data :request request :want-stream want-stream)))) + (cond ((typep raw-post-data 'stream) raw-post-data) + ((member raw-post-data '(t nil)) nil) + (external-format (octets-to-string raw-post-data :external-format external-format)) + (t raw-post-data)))) + +(defun aux-request-value (symbol &optional (request *request*)) + "Returns the value associated with SYMBOL from the request object +REQUEST \(the default is the current request) if it exists. The +second return value is true if such a value was found." + (when request + (let ((found (assoc symbol (aux-data request)))) + (values (cdr found) found)))) + +(defsetf aux-request-value (symbol &optional request) + (new-value) + "Sets the value associated with SYMBOL from the request object +REQUEST \(default is *REQUEST*). If there is already a value +associated with SYMBOL it will be replaced." + (with-rebinding (symbol) + (with-unique-names (place %request) + `(let* ((,%request (or ,request *request*)) + (,place (assoc ,symbol (aux-data ,%request)))) + (cond + (,place + (setf (cdr ,place) ,new-value)) + (t + (push (cons ,symbol ,new-value) + (aux-data ,%request)) + ,new-value)))))) + +(defun delete-aux-request-value (symbol &optional (request *request*)) + "Removes the value associated with SYMBOL from the request object +REQUEST." + (when request + (setf (aux-data request) + (delete symbol (aux-data request) + :key #'car :test #'eq))) + (values)) Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/server.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/server.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,440 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/server.lisp,v 1.38 2007/11/03 21:46:19 edi Exp $ + +;;; Copyright (c) 2004-2007, 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 server () + ((socket :accessor server-socket + :documentation "The socket the server is listening on.") + (port :initarg :port + :reader server-local-port + :documentation "The port the server is listening on. +See START-SERVER.") + (address :initarg :address + :reader server-address + :documentation "The address the server is listening +on. See START-SERVER.") + (name :initarg :name + :accessor server-name + :documentation "The optional name of the server, a symbol.") + (dispatch-table :initarg :dispatch-table + :accessor server-dispatch-table + :documentation "The dispatch-table used by this +server. Can be NIL to denote that *META-DISPATCHER* should be called +instead.") + (output-chunking-p :initarg :output-chunking-p + :reader server-output-chunking-p + :documentation "Whether the server may use output chunking.") + (input-chunking-p :initarg :input-chunking-p + :reader server-input-chunking-p + :documentation "Whether the server may use input chunking.") + (read-timeout :initarg :read-timeout + :reader server-read-timeout + :documentation "The read-timeout of the server.") + (write-timeout :initarg :write-timeout + :reader server-write-timeout + :documentation "The write-timeout of the server.") + (listener :accessor server-listener + :documentation "The Lisp process which listens for +incoming requests and starts new worker threads for each new +connection.") + (workers :initform nil + :accessor server-workers + :documentation "A list of currently active worker threads.") + (mod-lisp-p :initform nil + :initarg :mod-lisp-p + :reader server-mod-lisp-p + :documentation "Whether this is a genuine +Hunchentoot server or \"just\" infrastructure for mod_lisp.") + (use-apache-log-p :initarg :use-apache-log-p + :reader server-use-apache-log-p + :documentation "Whether the server should use +Apache's log file. Only applicable if MOD-LISP-P is true.") + #-:hunchentoot-no-ssl + (ssl-certificate-file :initarg :ssl-certificate-file + :reader server-ssl-certificate-file + :documentation "The namestring of a +certificate file if SSL is used, NIL otherwise.") + #-:hunchentoot-no-ssl + (ssl-privatekey-file :initarg :ssl-privatekey-file + :reader server-ssl-privatekey-file + :documentation "The namestring of a +private key file if SSL is used, NIL otherwise.") + #-:hunchentoot-no-ssl + (ssl-privatekey-password :initarg :ssl-privatekey-password + :reader server-ssl-privatekey-password + :documentation "The password for the +private key file or NIL.") + (lock :initform (make-lock (format nil "hunchentoot-lock-~A" + *server-counter*)) + :reader server-lock + :documentation "A lock which is used to make sure that +we can shutdown the server cleanly.")) + (:documentation "An object of this class contains all relevant +information about a running Hunchentoot server instance.")) + +(defun start-server (&key (port 80 port-provided-p) + address + dispatch-table + (name (gensym)) + (mod-lisp-p nil) + (use-apache-log-p mod-lisp-p) + (input-chunking-p t) + (read-timeout *default-read-timeout*) + (write-timeout *default-write-timeout*) + #+(and :unix (not :win32)) setuid + #+(and :unix (not :win32)) setgid + #-:hunchentoot-no-ssl ssl-certificate-file + #-:hunchentoot-no-ssl (ssl-privatekey-file ssl-certificate-file) + #-:hunchentoot-no-ssl ssl-privatekey-password) + "Starts a Hunchentoot server and returns the SERVER object \(which +can be stopped with STOP-SERVER). PORT is the port the server will be +listening on - the default is 80 \(or 443 if SSL information is +provided). If ADDRESS is a string denoting an IP address, then the +server only receives connections for that address. This must be one +of the addresses associated with the machine and allowed values are +host names such as \"www.nowhere.com\" and address strings like +\"204.71.177.75\". If ADDRESS is NIL, then the server will receive +connections to all IP addresses on the machine. This is the default. + +DISPATCH-TABLE can either be a dispatch table which is to be used by +this server or NIL which means that at request time *META-DISPATCHER* +will be called to retrieve a dispatch table. + +NAME should be a symbol which can be used to name the server. This +name can utilized when defining \"easy handlers\" - see +DEFINE-EASY-HANDLER. The default name is an uninterned symbol as +returned by GENSYM. + +If MOD-LISP-P is true, the server will act as a back-end for mod_lisp, +otherwise it will be a stand-alone web server. If USE-APACHE-LOG-P is +true, log messages will be written to the Apache log file - this +parameter has no effect if MOD-LISP-P is NIL. + +If INPUT-CHUNKING-P is true, the server will accept request bodies +without a `Content-Length' header if the client uses chunked transfer +encoding. If you want to use this feature together with mod_lisp, you +should make sure that your combination of Apache and mod_lisp can do +that - see: + + <http://common-lisp.net/pipermail/mod-lisp-devel/2006-December/000104.html>. + +On LispWorks 5.0 or higher and AllegroCL, READ-TIMEOUT and +WRITE-TIMEOUT are the read and write timeouts \(in seconds) of +the server - use NIL for no timeout at all. (See the LispWorks +documentation for STREAM:SOCKET-STREAM for details.) On +LispWorks 4.4.6 or lower, SBCL, and CMUCL WRITE-TIMEOUT is +ignored. On OpenMCL both parameters are ignored. + +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). + +If you want your server to use SSL you must provide the pathname +designator\(s) SSL-CERTIFICATE-FILE for the certificate file and +optionally SSL-PRIVATEKEY-FILE for the private key file, both files +must be in PEM format. If you only provide the value for +SSL-CERTIFICATE-FILE it is assumed that both the certificate and the +private key are in one file. If your private key needs a password you +can provide it through the SSL-PRIVATEKEY-PASSWORD keyword argument, +but this works only on LispWorks - for other Lisps the key must not be +associated with a password." + (declare (ignorable port-provided-p)) + ;; initialize the session secret if needed + (unless (boundp '*session-secret*) + (reset-session-secret)) + (let ((output-chunking-p t)) + #-:hunchentoot-no-ssl + (when ssl-certificate-file + ;; disable output chunking for SSL connections + (setq output-chunking-p nil) + (unless port-provided-p (setq port 443))) + ;; no timeouts if behind mod_lisp + (when mod-lisp-p + (setq read-timeout nil + write-timeout nil)) + ;; use a new process/lock name for each server + (atomic-incf *server-counter*) + ;; create the SERVER object + (let ((server (make-instance 'server + :port port + :address address + :name name + :dispatch-table dispatch-table + :output-chunking-p (and output-chunking-p (not mod-lisp-p)) + :input-chunking-p input-chunking-p + #-:hunchentoot-no-ssl :ssl-certificate-file + #-:hunchentoot-no-ssl(and ssl-certificate-file + (namestring ssl-certificate-file)) + #-:hunchentoot-no-ssl :ssl-privatekey-file + #-:hunchentoot-no-ssl (and ssl-privatekey-file + (namestring ssl-privatekey-file)) + #-:hunchentoot-no-ssl :ssl-privatekey-password + #-:hunchentoot-no-ssl ssl-privatekey-password + :mod-lisp-p mod-lisp-p + :use-apache-log-p (and mod-lisp-p use-apache-log-p) + :read-timeout read-timeout + :write-timeout write-timeout))) + (multiple-value-bind (process condition) + ;; start up the actual server + (start-up-server :service port + :address address + :process-name (format nil "hunchentoot-listener-~A" *server-counter*) + ;; this function is called once on + ;; startup - we use it to record the + ;; socket + :announce (lambda (socket &optional condition) + (cond (socket + (setf (server-socket server) socket)) + (condition + (error condition)))) + ;; this function is called whenever a + ;; connection is made + :function (lambda (handle) + (with-lock ((server-lock server)) + (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*))) + ;; start a worker thread + ;; for this connection + ;; and remember it + (push (process-run-function (format nil "hunchentoot-worker-~A" + *worker-counter*) + #'process-connection + server handle) + (server-workers server)))) + ;; wait until the server was + ;; successfully started or an error + ;; condition is returned + :wait t) + (cond (process + ;; remember the listener so we can kill it later + (setf (server-listener server) process)) + (condition + (error condition)))) + #+(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) + "Stops the Hunchentoot server SERVER." + ;; use lock so that the listener can't start new workers + (with-lock ((server-lock server)) + ;; kill all worker threads + (dolist (worker (server-workers server)) + (ignore-errors (process-kill worker)) + (process-allow-scheduling)) + ;; finally, kill main listener + (when-let (listener (server-listener server)) + (process-kill listener))) + (values)) + +(defun process-connection (server handle) + "This function is called by the server in a newly-created thread +with the SERVER object itself and a socket 'handle' from which a +stream can be created. 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 read timeout occurs." + (handler-bind ((error + ;; abort if there's an error which isn't caught inside + (lambda (cond) + (log-message *lisp-errors-log-level* + "Error while processing connection: ~A" cond) + (return-from process-connection))) + (warning + ;; log all warnings which aren't caught inside + (lambda (cond) + (log-message *lisp-warnings-log-level* + "Warning while processing connection: ~A" cond)))) + (with-debugger + (let (*hunchentoot-stream* *local-host* *remote-host* *remote-port*) + (unwind-protect + ;; bind important special variables + (let ((*server* server)) + ;; create binary stream from socket handle + (multiple-value-setq (*hunchentoot-stream* *local-host* *remote-host* *remote-port*) + (make-socket-stream handle + (server-read-timeout server) + (server-write-timeout server))) + ;; attach SSL to the stream if necessary + #-:hunchentoot-no-ssl + (when (server-ssl-certificate-file server) + #+:lispworks + (make-ssl-server-stream *hunchentoot-stream* + :certificate-file (server-ssl-certificate-file server) + :privatekey-file (server-ssl-privatekey-file server) + :privatekey-password (server-ssl-privatekey-password server)) + #-:lispworks + (setq *hunchentoot-stream* + (cl+ssl:make-ssl-server-stream *hunchentoot-stream* + :certificate (server-ssl-certificate-file server) + :key (server-ssl-privatekey-file server)))) + ;; wrap with chunking-enabled stream if necessary + (when (or (server-input-chunking-p server) + (server-output-chunking-p server)) + (setq *hunchentoot-stream* (make-chunked-stream *hunchentoot-stream*))) + ;; now wrap with flexi stream with "faithful" external format + (setq *hunchentoot-stream* + (make-flexi-stream *hunchentoot-stream* :external-format +latin-1+)) + ;; loop until we have to close the stream - as + ;; determined by *CLOSE-HUNCHENTOOT-STREAM* + (unwind-protect + (loop + (let ((*close-hunchentoot-stream* t)) + ;; reset to "faithful" format on each iteration + ;; and reset bound of stream as well + (setf (flexi-stream-external-format *hunchentoot-stream*) +latin-1+ + (flexi-stream-bound *hunchentoot-stream*) nil) + (multiple-value-bind (headers-in content-stream method url-string server-protocol) + (get-request-data) + (unless (and ;; check if there was a request at all + (cond ((server-mod-lisp-p server) headers-in) + (t method)) + (prog1 + (process-request headers-in content-stream method + url-string server-protocol) + ;; always turn chunking off at this point + (when (or (server-input-chunking-p server) + (server-output-chunking-p server)) + (setf (chunked-stream-output-chunking-p + (flexi-stream-stream *hunchentoot-stream*)) nil + (chunked-stream-input-chunking-p + (flexi-stream-stream *hunchentoot-stream*)) nil)) + (force-output* *hunchentoot-stream*)) + ;; continue until we have to close + ;; the stream + (not *close-hunchentoot-stream*)) + (return))))) + (ignore-errors (force-output* *hunchentoot-stream*)))) + (when *hunchentoot-stream* + (ignore-errors (close *hunchentoot-stream* :abort t))) + (ignore-errors + (with-lock ((server-lock server)) + ;; remove this worker from the list of all workers + (setf (server-workers server) + (delete *current-process* (server-workers server)))))))))) + +(defun process-request (headers-in content-stream method url-string server-protocol) + "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." + (let (*tmp-files* *headers-sent*) + (unwind-protect + (progn + (when (server-input-chunking-p *server*) + (let ((transfer-encodings (cdr (assoc :transfer-encoding headers-in)))) + (when transfer-encodings + (setq transfer-encodings + (split "\\s*,\\*" transfer-encodings))) + (when (member "chunked" transfer-encodings :test #'equalp) + ;; turn chunking on before we read the request body + (setf (chunked-stream-input-chunking-p + (flexi-stream-stream *hunchentoot-stream*)) t)))) + (let* ((*session* nil) + ;; first create a REPLY object so we can immediately start + ;; logging \(in case we're logging to mod_lisp) + (*reply* (make-instance 'reply)) + (*request* (make-instance 'request + :headers-in headers-in + :content-stream content-stream + :method method + :uri url-string + :server-protocol server-protocol)) + (*dispatch-table* (or (server-dispatch-table *server*) + (funcall *meta-dispatcher* *server*))) + backtrace) + (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)) + ;; if the headers were already sent + ;; the error happens within the body + ;; and we have to close the stream + (when *headers-sent* + (setq *close-hunchentoot-stream* t)) + (throw 'handler-done + (values nil cond)))) + (warning + (lambda (cond) + (when *log-lisp-warnings-p* + (log-message *lisp-warnings-log-level* + "~A~:[~*~;~%~A~]" + cond + *log-lisp-backtraces-p* + backtrace))))) + (with-debugger + ;; skip dispatch if bad request + (when (eq (return-code) +http-ok+) + ;; now do the work + (dispatch-request *dispatch-table*))))) + (when error + (setf (return-code *reply*) + +http-internal-server-error+)) + (start-output (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 + "An error has occured") + (t body)))) + t)) + (dolist (path *tmp-files*) + (when (and (pathnamep path) (probe-file path)) + (ignore-errors (delete-file path))))))) Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/session.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/session.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,286 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/session.lisp,v 1.11 2007/06/04 19:24:12 edi Exp $ + +;;; Copyright (c) 2004-2007, 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) + +(let ((session-id-counter 0)) + (defun get-next-session-id () + "Returns the next sequential session id." + (incf session-id-counter))) + +(let ((global-session-usage-counter 0)) + (defun count-session-usage () + "Counts session usage globally and triggers session gc if necessary." + (when (and *session-gc-frequency* + (zerop (mod (incf global-session-usage-counter) + *session-gc-frequency*))) + (session-gc)))) + + +(defclass session () + ((session-id :initform (get-next-session-id) + :reader session-id + :type integer + :documentation "The unique ID \(an INTEGER) of the session.") + (session-string :reader session-string + :documentation "The session strings encodes enough +data to safely retrieve this session. It is sent to the browser as a +cookie value or as a GET parameter.") + (user-agent :initform (user-agent *request*) + :reader session-user-agent + :documentation "The incoming 'User-Agent' header that +was sent when this session was created.") + (remote-addr :initform (real-remote-addr *request*) + :reader session-remote-addr + :documentation "The remote IP address of the client when +this sessions was started as returned by REAL-REMOTE-ADDR.") + (session-start :initform (get-universal-time) + :reader session-start + :documentation "The time this session was started.") + (last-click :initform (get-universal-time) + :reader session-last-click + :documentation "The last time this session was used.") + (session-data :initarg :session-data + :initform nil + :reader session-data + :documentation "Data associated with this session - +see SESSION-VALUE.") + (session-counter :initform 0 + :reader session-counter + :documentation "The number of times this session +has been used.") + (max-time :initarg :max-time + :initform *session-max-time* + :accessor session-max-time + :type fixnum + :documentation "The time \(in seconds) after which this +session expires if it's not used.")) + (:documentation "SESSION objects are automatically maintained +by Hunchentoot. They should not be created explicitly with +MAKE-INSTANCE but implicitly with START-SESSION. Note that +SESSION objects can only be created when the special variable +*REQUEST* is bound to a REQUEST object.")) + +(defun encode-session-string (id user-agent remote-addr start) + "Create a uniquely encoded session string based on the values ID, +USER-AGENT, REMOTE-ADDR, and START" + ;; *SESSION-SECRET* is used twice due to known theoretical + ;; vulnerabilities of MD5 encoding + (md5-hex (concatenate 'string + *session-secret* + (md5-hex (format nil "~A~A~@[~A~]~@[~A~]~A" + *session-secret* + id + (and *use-user-agent-for-sessions* + user-agent) + (and *use-remote-addr-for-sessions* + remote-addr) + start))))) + +(defun stringify-session (session) + "Creates a string representing the SESSION object SESSION. See +ENCODE-SESSION-STRING." + (encode-session-string (session-id session) + (session-user-agent session) + (session-remote-addr session) + (session-start session))) + +(defmethod initialize-instance :after ((session session) &rest init-args) + "Set SESSION-STRING slot after the session has been initialized." + (declare (ignore init-args)) + (setf (slot-value session 'session-string) (stringify-session session))) + +(defun session-gc () + "Removes sessions from *session-data* which are too old - see +SESSION-TOO-OLD-P." + (with-lock (*session-data-lock*) + (setq *session-data* + (loop for id-session-pair in *session-data* + for (nil . session) = id-session-pair + when (session-too-old-p session) + do (funcall *session-removal-hook* session) + else + collect id-session-pair))) + (values)) + +(defun session-value (symbol &optional (session *session*)) + "Returns the value associated with SYMBOL from the session object +SESSION \(the default is the current session) if it exists." + (when session + (let ((found (assoc symbol (session-data session)))) + (values (cdr found) found)))) + +(defsetf session-value (symbol &optional session) + (new-value) + "Sets the value associated with SYMBOL from the session object +SESSION. If there is already a value associated with SYMBOL it will be +replaced. Will automatically start a session if none was supplied and +there's no session for the current request." + (with-rebinding (symbol) + (with-unique-names (place %session) + `(with-lock (*session-data-lock*) + (let* ((,%session (or ,session (start-session))) + (,place (assoc ,symbol (session-data ,%session)))) + (cond + (,place + (setf (cdr ,place) ,new-value)) + (t + (push (cons ,symbol ,new-value) + (slot-value ,%session 'session-data)) + ,new-value))))))) + +(defun delete-session-value (symbol &optional (session *session*)) + "Removes the value associated with SYMBOL from the current session +object if there is one." + (when session + (setf (slot-value session 'session-data) + (delete symbol (session-data session) + :key #'car :test #'eq))) + (values)) + +(defun session-cookie-value (&optional (session (session *request*))) + "Returns a string which can be used to safely restore the +session if as session has already been established. This is used +as the value stored in the session cookie or in the corresponding +GET parameter." + (and session + (format nil + "~A:~A" + (session-id session) + (session-string session)))) + +(defun start-session () + "Returns the current SESSION object. If there is no current session, +creates one and updates the corresponding data structures. In this +case the function will also send a session cookie to the browser." + (count-session-usage) + (let ((session (session *request*))) + (when session + (return-from start-session session)) + (setf session (make-instance 'session) + (session *request*) session) + (with-lock (*session-data-lock*) + (setq *session-data* (acons (session-id session) session *session-data*))) + (set-cookie *session-cookie-name* + :value (session-cookie-value session) + :path "/") + (setq *session* session))) + +(defun remove-session (session) + "Completely removes the SESSION object SESSION from Hunchentoot's +internal session database." + (with-lock (*session-data-lock*) + (funcall *session-removal-hook* session) + (setq *session-data* + (delete (session-id session) *session-data* + :key #'car :test #'=))) + (values)) + +(defun session-too-old-p (session) + "Returns true if the SESSION object SESSION has not been active in +the last \(SESSION-MAX-TIME SESSION) seconds." + (< (+ (session-last-click session) (session-max-time session)) + (get-universal-time))) + +(defun get-stored-session (id) + "Returns the SESSION object corresponding to the number ID if the +session has not expired. Will remove the session if it has expired but +will not create a new one." + (let ((session + (cdr (assoc id *session-data* :test #'=)))) + (when (and session + (session-too-old-p session)) + (when *reply* + (log-message :notice "Session with ID ~A too old" id)) + (remove-session session) + (setq session nil)) + session)) + +(defun session-verify (request) + "Tries to get a session identifier from the cookies \(or +alternatively from the GET parameters) sent by the client. This +identifier is then checked for validity against the REQUEST object +REQUEST. On success the corresponding session object \(if not too old) +is returned \(and updated). Otherwise NIL is returned." + (let ((session-identifier (or (cookie-in *session-cookie-name* request) + (get-parameter *session-cookie-name* request)))) + (unless (and session-identifier + (stringp session-identifier) + (plusp (length session-identifier))) + (return-from session-verify nil)) + (destructuring-bind (id-string session-string) + (split ":" session-identifier :limit 2) + (let* ((id (and (scan "^\\d+$" id-string) + (parse-integer id-string + :junk-allowed t))) + (session (and id + (get-stored-session id))) + (user-agent (user-agent request)) + (remote-addr (remote-addr request))) + (unless (and session + session-string + (string= session-string + (session-string session)) + (string= session-string + (encode-session-string id + user-agent + (real-remote-addr request) + (session-start session)))) + (when *reply* + (cond ((null session) + (log-message :notice "No session for session identifier '~A' (User-Agent: '~A', IP: '~A')" + session-identifier user-agent remote-addr)) + (t + (log-message :warning "Fake session identifier '~A' (User-Agent: '~A', IP: '~A')" + session-identifier user-agent remote-addr)))) + (when session + (remove-session session)) + (return-from session-verify nil)) + (incf (slot-value session 'session-counter)) + (setf (slot-value session 'last-click) (get-universal-time)) + session)))) + +(defun reset-sessions () + "Removes ALL stored sessions and creates a new session secret." + (reset-session-secret) + (with-lock (*session-data-lock*) + (loop for (nil . session) in *session-data* + do (funcall *session-removal-hook* session)) + (setq *session-data* nil)) + (values)) + +(defmacro do-sessions ((var &optional result-form) &body body) + "Executes BODY with VAR bound to each existing SESSION object +consecutively. Returns the values returned by RESULT-FORM unless +RETURN is executed. The scope of the binding of VAR does not include +RESULT-FORM." + (let ((=temp= (gensym))) + `(dolist (,=temp= *session-data* ,result-form) + (let ((,var (cdr ,=temp=))) + ,@body)))) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/specials.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/specials.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,385 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/specials.lisp,v 1.31 2007/11/08 20:07:58 edi Exp $ + +;;; Copyright (c) 2004-2007, 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 :execute :load-toplevel) + (defmacro defvar-unbound (name &optional (doc-string "")) + "Convenience macro to declare unbound special variables with a +documentation string." + `(progn + (defvar ,name) + (setf (documentation ',name 'variable) ,doc-string))) + + (defvar *http-reason-phrase-map* (make-hash-table) + "Used to map numerical return codes to reason phrases.") + + (defmacro def-http-return-code (name value reason-phrase) + "Shortcut to define constants for return codes. NAME is a +Lisp symbol, VALUE is the numerical value of the return code, and +REASON-PHRASE is the phrase \(a string) to be shown in the +server's status line." + `(eval-when (:compile-toplevel :execute :load-toplevel) + (defconstant ,name ,value ,(format nil "HTTP return code \(~A) for '~A'." + value reason-phrase)) + (setf (gethash ,value *http-reason-phrase-map*) ,reason-phrase)))) + +(defconstant +crlf+ #.(format nil "~C~C" #\Return #\Linefeed) + "A constant string consisting of the two ASCII characters CR and LF.") + +(def-http-return-code +http-continue+ 100 "Continue") +(def-http-return-code +http-switching-protocols+ 101 "Switching Protocols") +(def-http-return-code +http-ok+ 200 "OK") +(def-http-return-code +http-created+ 201 "Created") +(def-http-return-code +http-accepted+ 202 "Accepted") +(def-http-return-code +http-non-authoritative-information+ 203 "Non-Authoritative Information") +(def-http-return-code +http-no-content+ 204 "No Content") +(def-http-return-code +http-reset-content+ 205 "Reset Content") +(def-http-return-code +http-partial-content+ 206 "Partial Content") +(def-http-return-code +http-multi-status+ 207 "Multi-Status") +(def-http-return-code +http-multiple-choices+ 300 "Multiple Choices") +(def-http-return-code +http-moved-permanently+ 301 "Moved Permanently") +(def-http-return-code +http-moved-temporarily+ 302 "Moved Temporarily") +(def-http-return-code +http-see-other+ 303 "See Other") +(def-http-return-code +http-not-modified+ 304 "Not Modified") +(def-http-return-code +http-use-proxy+ 305 "Use Proxy") +(def-http-return-code +http-temporary-redirect+ 307 "Temporary Redirect") +(def-http-return-code +http-bad-request+ 400 "Bad Request") +(def-http-return-code +http-authorization-required+ 401 "Authorization Required") +(def-http-return-code +http-payment-required+ 402 "Payment Required") +(def-http-return-code +http-forbidden+ 403 "Forbidden") +(def-http-return-code +http-not-found+ 404 "Not Found") +(def-http-return-code +http-method-not-allowed+ 405 "Method Not Allowed") +(def-http-return-code +http-not-acceptable+ 406 "Not Acceptable") +(def-http-return-code +http-proxy-authentication-required+ 407 "Proxy Authentication Required") +(def-http-return-code +http-request-time-out+ 408 "Request Time-out") +(def-http-return-code +http-conflict+ 409 "Conflict") +(def-http-return-code +http-gone+ 410 "Gone") +(def-http-return-code +http-length-required+ 411 "Length Required") +(def-http-return-code +http-precondition-failed+ 412 "Precondition Failed") +(def-http-return-code +http-request-entity-too-large+ 413 "Request Entity Too Large") +(def-http-return-code +http-request-uri-too-large+ 414 "Request-URI Too Large") +(def-http-return-code +http-unsupported-media-type+ 415 "Unsupported Media Type") +(def-http-return-code +http-requested-range-not-satisfiable+ 416 "Requested range not satisfiable") +(def-http-return-code +http-expectation-failed+ 417 "Expectation Failed") +(def-http-return-code +http-failed-dependency+ 424 "Failed Dependency") +(def-http-return-code +http-internal-server-error+ 500 "Internal Server Error") +(def-http-return-code +http-not-implemented+ 501 "Not Implemented") +(def-http-return-code +http-bad-gateway+ 502 "Bad Gateway") +(def-http-return-code +http-service-unavailable+ 503 "Service Unavailable") +(def-http-return-code +http-gateway-time-out+ 504 "Gateway Time-out") +(def-http-return-code +http-version-not-supported+ 505 "Version not supported") + +(defvar *approved-return-codes* '(#.+http-ok+ #.+http-no-content+ + #.+http-multi-status+ + #.+http-not-modified+) + "A list of return codes the server should not treat as an error - +see *HANDLE-HTTP-ERRORS-P*.") + +(defconstant +day-names+ + #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") + "The three-character names of the seven days of the week - needed +for cookie date format.") + +(defconstant +month-names+ + #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + "The three-character names of the twelve months - needed for cookie +date format.") + +(defvar *session-cookie-name* "hunchentoot-session" + "The name of the cookie \(or the GET parameter) which is used to +store the session on the client side.") + +(defvar *rewrite-for-session-urls* t + "Whether HTML pages should possibly be rewritten for cookie-less +session-management.") + +(defvar *content-types-for-url-rewrite* + '("text/html" "application/xhtml+xml") + "The content types for which url-rewriting is OK. See +*REWRITE-FOR-SESSION-URLS*.") + +(defparameter *the-random-state* (make-random-state t) + "A fresh random state.") + +(defvar-unbound *session-secret* + "A random value that's used to encode the public session data.") + +(defvar-unbound *hunchentoot-stream* + "The stream representing the socket Hunchentoot is listening on.") + +(defvar *close-hunchentoot-stream* nil + "Will be set to T if the Hunchentoot socket stream has to be +closed at the end of the request.") + +(defvar *headers-sent* nil + "Used internally to check whether the reply headers have +already been sent for this request.") + +(defvar *file-upload-hook* nil + "If this is not NIL, it should be a unary function which will +be called with a pathname for each file which is uploaded to +Hunchentoot. The pathname denotes the temporary file to which +the uploaded file is written. The hook is called directly before +the file is created.") + +(defvar *session-data* nil + "All sessions of all users currently using Hunchentoot. An +alist where the car is the session's ID and the cdr is the +SESSION object itself.") + +(defvar *session-max-time* #.(* 30 60) + "The default time \(in seconds) after which a session times out.") + +(defvar *session-gc-frequency* 50 + "A session GC \(see function SESSION-GC) will happen every +*SESSION-GC-FREQUENCY* requests \(counting only requests which +use a session) if this variable is not NIL.") + +(defvar *use-user-agent-for-sessions* t + "Whether the 'User-Agent' header should be encoded into the session +string. If this value is true, a session will cease to be accessible +if the client sends a different 'User-Agent' header.") + +(defvar *use-remote-addr-for-sessions* nil + "Whether the client's remote IP \(as returned by REAL-REMOTE-ADDR) +should be encoded into the session string. If this value is true, a +session will cease to be accessible if the client's remote IP changes. + +This might for example be an issue if the client uses a proxy server +which doesn't send correct 'X_FORWARDED_FOR' headers.") + +(defvar *default-content-type* "text/html; charset=iso-8859-1" + "The default content-type header which is returned to the client.") + +(defvar *methods-for-post-parameters* '(:post) + "A list of the request method types \(as keywords) for which +Hunchentoot will try to compute POST-PARAMETERS.") + +(defvar *header-stream* nil + "If this variable is not NIL, it should be bound to a stream to +which incoming and outgoing headers will be written for debugging +purposes.") + +(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.") + +(defvar *lisp-warnings-log-level* :warning + "Log level for Lisp warnings.") + +(defvar *show-access-log-messages* t + "Whether routine messages about each request should be logged. This +will only be done if SERVER-USE-APACHE-LOG-P is NIL.") + +(defvar *log-file* + (load-time-value + (let ((tmp-dir + #+:allegro (system:temporary-directory) + #+:lispworks (pathname (or (lw:environment-variable "TEMP") + (lw:environment-variable "TMP") + #+:win32 "C:/" + #-:win32 "/tmp/")) + #-(or :allegro :lispworks) #p"/tmp/")) + (merge-pathnames "hunchentoot.log" tmp-dir))) + "The log file to use \(unless the Apache log is used).") + +(defvar *log-file-stream* nil + "The stream corresponding to the log file.") + +(defvar *log-file-lock* (make-lock "log-file-lock") + "A lock to prevent two threads from writing to the log file at +same time.") + +(defvar-unbound *session* + "The current SESSION object.") + +(defvar-unbound *request* + "The current REQUEST object.") + +(defvar-unbound *reply* + "The current REPLY object.") + +(defvar *log-prefix* t + "The prefix which is printed in front of Apache log +messages. This should be a string or T \(for \"Hunchentoot\", the +default) or NIL \(meaning no prefix).") + +(defconstant +implementation-link+ + #+:cmu "http://www.cons.org/cmucl/" + #+:sbcl "http://www.sbcl.org/" + #+:allegro "http://www.franz.com/products/allegrocl/" + #+:lispworks "http://www.lispworks.com/" + #+:openmcl "http://openmcl.clozure.com/" + "A link to the website of the underlying Lisp implementation.") + +(defvar *dispatch-table* (list 'default-dispatcher) + "A list of dispatch functions - see *META-DISPATCHER*.") + +(defvar *default-handler* 'default-handler + "The name of the function which is always returned by +DEFAULT-DISPATCHER.") + +(defvar *easy-handler-alist* nil + "An alist of \(URI server-names function) lists defined by +DEFINE-EASY-HANDLER.") + +(defvar *http-error-handler* nil + "Contains NIL \(the default) or a function of one argument which is +called if the content handler has set a return code which is not in +*APPROVED-RETURN-CODES* and *HANDLE-HTTP-ERRORS* is true.") + +(defvar *handle-http-errors-p* t + "A generalized boolean that determines whether return codes which +are not in *APPROVED-HEADERS* are treated specially. When its value +is true \(the default), either a default body for the return code or +the result of calling *HTTP-ERROR-HANDLER* is used. When the value is +NIL, no special action is taken and you are expected to supply your +own response body to describe the error.") + +(defvar *default-log-level* nil + "The default log level for LOG-MESSAGE*.") + +(defvar *session-data-lock* (make-lock "session-data-lock") + "A lock to prevent two threads from modifying *SESSION-DATA* at the +same time.") + +(defvar *session-removal-hook* (constantly nil) + "A function of one argument \(a session object) which is called +whenever a session is garbage-collected.") + +(defvar *tmp-directory* + #+(or :win32 :mswindows) "c:\\hunchentoot-temp\\" + #-(or :win32 :mswindows) "/tmp/hunchentoot/" + "Directory for temporary files created by MAKE-TMP-FILE-NAME.") + +(defvar *tmp-files* nil + "A list of temporary files created while a request was handled.") + +(defconstant +latin-1+ + (make-external-format :latin1 :eol-style :lf) + "A FLEXI-STREAMS external format used for `faithful' input and +output of binary data.") + +(defconstant +utf-8+ + (make-external-format :utf8 :eol-style :lf) + "A FLEXI-STREAMS external format used internally for logging and to +encode cookie values.") + +(defvar *hunchentoot-default-external-format* +latin-1+ + "The external format used to compute the REQUEST object.") + +(defconstant +buffer-length+ 8192 + "Length of buffers used for internal purposes.") + +(defvar-unbound *server* + "During the execution of dispatchers and handlers this variable +is bound to the SERVER object which processes the request.") + +(defvar *meta-dispatcher* (lambda (server) + (declare (ignore server)) + *dispatch-table*) + "The value of this variable should be a function of one argument. +It is called with the current Hunchentoot server instance \(unless the +server has its own dispatch table) and must return a suitable dispatch +table. The initial value is a function which always unconditionally +returns *DISPATCH-TABLE*.") + +(defvar *server-counter* 0 + "Internal counter used to generate meaningful names for +listener threads.") + +(defvar *worker-counter* 0 + "Internal counter used to generate meaningful names for worker +threads.") + +(defvar *default-read-timeout* 20 + "The default read-timeout used when a Hunchentoot server is +reading from a socket stream.") + +(defvar *default-write-timeout* 20 + "The default write-timeout used when a Hunchentoot server is +writing to a socket stream.") + +(defvar *force-output-timeout* 30 + "The maximal time Hunchentoot waits for FORCE-OUTPUT to +return.") + +(defvar *cleanup-interval* 100 + "Should be NIL or a positive integer. The system calls +*CLEANUP-FUNCTION* whenever *CLEANUP-INTERVAL* new worker threads have +been created unless the value is NIL.") + +(defvar *cleanup-function* 'cleanup-function + "The function which is called if *CLEANUP-INTERVAL* is not NIL.") + +(defvar-unbound *local-host* + "Bound to a string denoting the address at which the current +request arrived.") + +(defvar-unbound *remote-host* + "Bound to a string denoting the address the current request +originated from.") + +(defvar-unbound *remote-port* + "Bound to an integer denoting the port the current request +originated from.") + +(pushnew :hunchentoot *features*) + +;; stuff for Nikodemus Siivola's HYPERDOC +;; see <http://common-lisp.net/project/hyperdoc/> +;; and <http://www.cliki.net/hyperdoc> + +(defvar *hyperdoc-base-uri* "http://weitz.de/hunchentoot/") + +(let ((exported-symbols-alist + (loop for symbol being the external-symbols of :hunchentoot + collect (cons symbol (concatenate 'string "#" (string-downcase symbol)))))) + (defun hyperdoc-lookup (symbol type) + (declare (ignore type)) + (cdr (assoc symbol exported-symbols-alist :test #'eq)))) Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/UTF-8-demo.html ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/UTF-8-demo.html Thu Feb 7 03:16:29 2008 @@ -0,0 +1,213 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml"> + <head><title>UTF-8 test file</title></head> + <body> + Original by Markus Kuhn, adapted for HTML by Martin Dürst. +<pre> +UTF-8 encoded sample plain-text file +‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ + +Markus Kuhn [ˈmaʳkʊs kuːn] <mkuhn(a)acm.org> — 1999-08-20 + + +The ASCII compatible UTF-8 encoding of ISO 10646 and Unicode +plain-text files is defined in RFC 2279 and in ISO 10646-1 Annex R. + + +Using Unicode/UTF-8, you can write in emails and source code things such as + +Mathematics and Sciences: + + ∮ E⋅da = Q, n → ∞, ∑ f(i) = ∏ g(i), ∀x∈ℝ: ⌈x⌉ = −⌊−x⌋, α ∧ ¬β = ¬(¬α ∨ β), + + ℕ ⊆ ℕ₀ ⊂ ℤ ⊂ ℚ ⊂ ℝ ⊂ ℂ, ⊥ < a ≠ b ≡ c ≤ d ≪ ⊤ ⇒ (A ⇔ B), + + 2H₂ + O₂ ⇌ 2H₂O, R = 4.7 kΩ, ⌀ 200 mm + +Linguistics and dictionaries: + + ði ıntəˈnæʃənəl fəˈnɛtık əsoʊsiˈeıʃn + Y [ˈʏpsilɔn], Yen [jɛn], Yoga [ˈjoːgɑ] + +APL: + + ((V⍳V)=⍳⍴V)/V←,V ⌷←⍳→⍴∆∇⊃‾⍎⍕⌈ + +Nicer typography in plain text files: + + ╔══════════════════════════════════════════╗ + ║ ║ + ║ • ‘single’ and “double” quotes ║ + ║ ║ + ║ • Curly apostrophes: “We’ve been here” ║ + ║ ║ + ║ • Latin-1 apostrophe and accents: '´` ║ + ║ ║ + ║ • ‚deutsche‘ „Anführungszeichen“ ║ + ║ ║ + ║ • †, ‡, ‰, •, 3–4, —, −5/+5, ™, … ║ + ║ ║ + ║ • ASCII safety test: 1lI|, 0OD, 8B ║ + ║ ╭─────────╮ ║ + ║ • the euro symbol: │ 14.95 € │ ║ + ║ ╰─────────╯ ║ + ╚══════════════════════════════════════════╝ + +Greek (in Polytonic): + + The Greek anthem: + + Σὲ γνωρίζω ἀπὸ τὴν κόψη + τοῦ σπαθιοῦ τὴν τρομερή, + σὲ γνωρίζω ἀπὸ τὴν ὄψη + ποὺ μὲ βία μετράει τὴ γῆ. + + ᾿Απ᾿ τὰ κόκκαλα βγαλμένη + τῶν ῾Ελλήνων τὰ ἱερά + καὶ σὰν πρῶτα ἀνδρειωμένη + χαῖρε, ὦ χαῖρε, ᾿Ελευθεριά! + + From a speech of Demosthenes in the 4th century BC: + + Οὐχὶ ταὐτὰ παρίσταταί μοι γιγνώσκειν, ὦ ἄνδρες ᾿Αθηναῖοι, + ὅταν τ᾿ εἰς τὰ πράγματα ἀποβλέψω καὶ ὅταν πρὸς τοὺς + λόγους οὓς ἀκούω· τοὺς μὲν γὰρ λόγους περὶ τοῦ + τιμωρήσασθαι Φίλιππον ὁρῶ γιγνομένους, τὰ δὲ πράγματ᾿ + εἰς τοῦτο προήκοντα, ὥσθ᾿ ὅπως μὴ πεισόμεθ᾿ αὐτοὶ + πρότερον κακῶς σκέψασθαι δέον. οὐδέν οὖν ἄλλο μοι δοκοῦσιν + οἱ τὰ τοιαῦτα λέγοντες ἢ τὴν ὑπόθεσιν, περὶ ἧς βουλεύεσθαι, + οὐχὶ τὴν οὖσαν παριστάντες ὑμῖν ἁμαρτάνειν. ἐγὼ δέ, ὅτι μέν + ποτ᾿ ἐξῆν τῇ πόλει καὶ τὰ αὑτῆς ἔχειν ἀσφαλῶς καὶ Φίλιππον + τιμωρήσασθαι, καὶ μάλ᾿ ἀκριβῶς οἶδα· ἐπ᾿ ἐμοῦ γάρ, οὐ πάλαι + γέγονεν ταῦτ᾿ ἀμφότερα· νῦν μέντοι πέπεισμαι τοῦθ᾿ ἱκανὸν + προλαβεῖν ἡμῖν εἶναι τὴν πρώτην, ὅπως τοὺς συμμάχους + σώσομεν. ἐὰν γὰρ τοῦτο βεβαίως ὑπάρξῃ, τότε καὶ περὶ τοῦ + τίνα τιμωρήσεταί τις καὶ ὃν τρόπον ἐξέσται σκοπεῖν· πρὶν δὲ + τὴν ἀρχὴν ὀρθῶς ὑποθέσθαι, μάταιον ἡγοῦμαι περὶ τῆς + τελευτῆς ὁντινοῦν ποιεῖσθαι λόγον. + + Δημοσθένους, Γ´ ᾿Ολυνθιακὸς + +Georgian: + + From a Unicode conference invitation: + + გთხოვთ ახლავე გაიაროთ რეგისტრაცია Unicode-ის მეათე საერთაშორისო + კონფერენციაზე დასასწრებად, რომელიც გაიმართება 10-12 მარტს, + ქ. მაინცში, გერმანიაში. კონფერენცია შეჰკრებს ერთად მსოფლიოს + ექსპერტებს ისეთ დარგებში როგორიცაა ინტერნეტი და Unicode-ი, + ინტერნაციონალიზაცია და ლოკალიზაცია, Unicode-ის გამოყენება + ოპერაციულ სისტემებსა, და გამოყენებით პროგრამებში, შრიფტებში, + ტექსტების დამუშავებასა და მრავალენოვან კომპიუტერულ სისტემებში. + +Russian: + + From a Unicode conference invitation: + + Зарегистрируйтесь сейчас на Десятую Международную Конференцию по + Unicode, которая состоится 10-12 марта 1997 года в Майнце в Германии. + Конференция соберет широкий круг экспертов по вопросам глобального + Интернета и Unicode, локализации и интернационализации, воплощению и + применению Unicode в различных операционных системах и программных + приложениях, шрифтах, верстке и многоязычных компьютерных системах. + +Thai (UCS Level 2): + + Excerpt from a poetry on The Romance of The Three Kingdoms (a Chinese + classic 'San Gua'): + + [----------------------------|------------------------] + ๏ แผ่นดินฮั่นเสื่อมโทรมแสนสังเวช พระปกเกศกองบู๊กู้ขึ้นใหม่ + สิบสองกษัตริย์ก่อนหน้าแลถัดไป สององค์ไซร้โง่เขลาเบาปัญญา + ทรงนับถือขันทีเป็นที่พึ่ง บ้านเมืองจึงวิปริตเป็นนักหนา + โฮจิ๋นเรียกทัพทั่วหัวเมืองมา หมายจะฆ่ามดชั่วตัวสำคัญ + เหมือนขับไสไล่เสือจากเคหา รับหมาป่าเข้ามาเลยอาสัญ + ฝ่ายอ้องอุ้นยุแยกให้แตกกัน ใช้สาวนั้นเป็นชนวนชื่นชวนใจ + พลันลิฉุยกุยกีกลับก่อเหตุ ช่างอาเพศจริงหนาฟ้าร้องไห้ + ต้องรบราฆ่าฟันจนบรรลัย ฤๅหาใครค้ำชูกู้บรรลังก์ ฯ + + (The above is a two-column text. If combining characters are handled + correctly, the lines of the second column should be aligned with the + | character above.) + +Ethiopian: + + Proverbs in the Amharic language: + + ሰማይ አይታረስ ንጉሥ አይከሰስ። + ብላ ካለኝ እንደአባቴ በቆመጠኝ። + ጌጥ ያለቤቱ ቁምጥና ነው። + ደሀ በሕልሙ ቅቤ ባይጠጣ ንጣት በገደለው። + የአፍ ወለምታ በቅቤ አይታሽም። + አይጥ በበላ ዳዋ ተመታ። + ሲተረጉሙ ይደረግሙ። + ቀስ በቀስ፥ ዕንቁላል በእግሩ ይሄዳል። + ድር ቢያብር አንበሳ ያስር። + ሰው እንደቤቱ እንጅ እንደ ጉረቤቱ አይተዳደርም። + እግዜር የከፈተውን ጉሮሮ ሳይዘጋው አይድርም። + የጎረቤት ሌባ፥ ቢያዩት ይስቅ ባያዩት ያጠልቅ። + ሥራ ከመፍታት ልጄን ላፋታት። + ዓባይ ማደሪያ የለው፥ ግንድ ይዞ ይዞራል። + የእስላም አገሩ መካ የአሞራ አገሩ ዋርካ። + ተንጋሎ ቢተፉ ተመልሶ ባፉ። + ወዳጅህ ማር ቢሆን ጨርስህ አትላሰው። + እግርህን በፍራሽህ ልክ ዘርጋ። + +Runes: + + ᚻᛖ ᚳᚹᚫᚦ ᚦᚫᛏ ᚻᛖ ᛒᚢᛞᛖ ᚩᚾ ᚦᚫᛗ ᛚᚪᚾᛞᛖ ᚾᚩᚱᚦᚹᛖᚪᚱᛞᚢᛗ ᚹᛁᚦ ᚦᚪ ᚹᛖᛥᚫ + + (Old English, which transcribed into Latin reads 'He cwaeth that he + bude thaem lande northweardum with tha Westsae.' and means 'He said + that he lived in the northern land near the Western Sea.') + +Braille: + + ⡌⠁⠧⠑ ⠼⠁⠒ ⡍⠜⠇⠑⠹⠰⠎ ⡣⠕⠌ + + ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠙⠑⠁⠙⠒ ⠞⠕ ⠃⠑⠛⠔ ⠺⠊⠹⠲ ⡹⠻⠑ ⠊⠎ ⠝⠕ ⠙⠳⠃⠞ + ⠱⠁⠞⠑⠧⠻ ⠁⠃⠳⠞ ⠹⠁⠞⠲ ⡹⠑ ⠗⠑⠛⠊⠌⠻ ⠕⠋ ⠙⠊⠎ ⠃⠥⠗⠊⠁⠇ ⠺⠁⠎ + ⠎⠊⠛⠝⠫ ⠃⠹ ⠹⠑ ⠊⠇⠻⠛⠹⠍⠁⠝⠂ ⠹⠑ ⠊⠇⠻⠅⠂ ⠹⠑ ⠥⠝⠙⠻⠞⠁⠅⠻⠂ + ⠁⠝⠙ ⠹⠑ ⠡⠊⠑⠋ ⠍⠳⠗⠝⠻⠲ ⡎⠊⠗⠕⠕⠛⠑ ⠎⠊⠛⠝⠫ ⠊⠞⠲ ⡁⠝⠙ + ⡎⠊⠗⠕⠕⠛⠑⠰⠎ ⠝⠁⠍⠑ ⠺⠁⠎ ⠛⠕⠕⠙ ⠥⠏⠕⠝ ⠰⡡⠁⠝⠛⠑⠂ ⠋⠕⠗ ⠁⠝⠹⠹⠔⠛ ⠙⠑ + ⠡⠕⠎⠑ ⠞⠕ ⠏⠥⠞ ⠙⠊⠎ ⠙⠁⠝⠙ ⠞⠕⠲ + + ⡕⠇⠙ ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲ + + ⡍⠔⠙⠖ ⡊ ⠙⠕⠝⠰⠞ ⠍⠑⠁⠝ ⠞⠕ ⠎⠁⠹ ⠹⠁⠞ ⡊ ⠅⠝⠪⠂ ⠕⠋ ⠍⠹ + ⠪⠝ ⠅⠝⠪⠇⠫⠛⠑⠂ ⠱⠁⠞ ⠹⠻⠑ ⠊⠎ ⠏⠜⠞⠊⠊⠥⠇⠜⠇⠹ ⠙⠑⠁⠙ ⠁⠃⠳⠞ + ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲ ⡊ ⠍⠊⠣⠞ ⠙⠁⠧⠑ ⠃⠑⠲ ⠔⠊⠇⠔⠫⠂ ⠍⠹⠎⠑⠇⠋⠂ ⠞⠕ + ⠗⠑⠛⠜⠙ ⠁ ⠊⠕⠋⠋⠔⠤⠝⠁⠊⠇ ⠁⠎ ⠹⠑ ⠙⠑⠁⠙⠑⠌ ⠏⠊⠑⠊⠑ ⠕⠋ ⠊⠗⠕⠝⠍⠕⠝⠛⠻⠹ + ⠔ ⠹⠑ ⠞⠗⠁⠙⠑⠲ ⡃⠥⠞ ⠹⠑ ⠺⠊⠎⠙⠕⠍ ⠕⠋ ⠳⠗ ⠁⠝⠊⠑⠌⠕⠗⠎ + ⠊⠎ ⠔ ⠹⠑ ⠎⠊⠍⠊⠇⠑⠆ ⠁⠝⠙ ⠍⠹ ⠥⠝⠙⠁⠇⠇⠪⠫ ⠙⠁⠝⠙⠎ + ⠩⠁⠇⠇ ⠝⠕⠞ ⠙⠊⠌⠥⠗⠃ ⠊⠞⠂ ⠕⠗ ⠹⠑ ⡊⠳⠝⠞⠗⠹⠰⠎ ⠙⠕⠝⠑ ⠋⠕⠗⠲ ⡹⠳ + ⠺⠊⠇⠇ ⠹⠻⠑⠋⠕⠗⠑ ⠏⠻⠍⠊⠞ ⠍⠑ ⠞⠕ ⠗⠑⠏⠑⠁⠞⠂ ⠑⠍⠏⠙⠁⠞⠊⠊⠁⠇⠇⠹⠂ ⠹⠁⠞ + ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲ + + (The first couple of paragraphs of "A Christmas Carol" by Dickens) + +Compact font selection example text: + + ABCDEFGHIJKLMNOPQRSTUVWXYZ /0123456789 + abcdefghijklmnopqrstuvwxyz £©µÀÆÖÞßéöÿ + –—‘“”„†•…‰™œŠŸž€ ΑΒΓΔΩαβγδω АБВГДабвгд + ∀∂∈ℝ∧∪≡∞ ↑↗↨↻⇣ ┐┼╔╘░►☺♀ ﬁ�⑀₂ἠḂӥẄɐː⍎אԱა + +Greetings in various languages: + + Hello world, Καλημέρα κόσμε, コンニチハ + +Box drawing alignment tests: █ + ▉ + ╔══╦══╗ ┌──┬──┐ ╭──┬──╮ ╭──┬──╮ ┏━━┳━━┓ ┎┒┏┑ ╷ ╻ ┏┯┓ ┌┰┐ ▊ ╱╲╱╲╳╳╳ + ║┌─╨─┐║ │╔═╧═╗│ │╒═╪═╕│ │╓─╁─╖│ ┃┌─╂─┐┃ ┗╃╄┙ ╶┼╴╺╋╸┠┼┨ ┝╋┥ ▋ ╲╱╲╱╳╳╳ + ║│╲ ╱│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╿ │┃ ┍╅╆┓ ╵ ╹ ┗┷┛ └┸┘ ▌ ╱╲╱╲╳╳╳ + ╠╡ ╳ ╞╣ ├╢ ╟┤ ├┼─┼─┼┤ ├╫─╂─╫┤ ┣┿╾┼╼┿┫ ┕┛┖┚ ┌┄┄┐ ╎ ┏┅┅┓ ┋ ▍ ╲╱╲╱╳╳╳ + ║│╱ ╲│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╽ │┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▎ + ║└─╥─┘║ │╚═╤═╝│ │╘═╪═╛│ │╙─╀─╜│ ┃└─╂─┘┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▏ + ╚══╩══╝ └──┴──┘ ╰──┴──╯ ╰──┴──╯ ┗━━┻━━┛ └╌╌┘ ╎ ┗╍╍┛ ┋ ▁▂▃▄▅▆▇█ + +</pre> +</body> +</html> Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/favicon.ico ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/fz.jpg ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/packages.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/packages.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,37 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/test/packages.lisp,v 1.4 2007/01/01 23:50:32 edi Exp $ + +;;; Copyright (c) 2004-2007, 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 :cl-user) + +(defpackage :hunchentoot-test + (:nicknames :tbnl-test) + (:use :cl :cl-who :hunchentoot)) + +(defpackage :hunchentoot-test-user + (:use :cl :hunchentoot)) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/test.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/test.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,584 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/test/test.lisp,v 1.21 2007/12/29 17:35:05 edi Exp $ + +;;; Copyright (c) 2004-2007, 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-test) + +(defvar *this-file* (load-time-value + (or #.*compile-file-pathname* *load-pathname*))) + +(defmacro with-html (&body body) + `(with-html-output-to-string (*standard-output* nil :prologue t) + ,@body)) + +(defun hunchentoot-link () + (with-html-output (*standard-output*) + (:a :href "http://weitz.de/hunchentoot/" "Hunchentoot"))) + +(defun menu-link () + (with-html-output (*standard-output*) + (:p (:hr + (:a :href "/hunchentoot/test" "Back to menu"))))) + +(defmacro with-lisp-output ((var) &body body) + `(let ((*package* (find-package :hunchentoot-test-user))) + (with-output-to-string (,var #+:lispworks nil + #+:lispworks :element-type + #+:lispworks 'lw:simple-char) + ,@body))) + +(defmacro info-table (&rest forms) + (let ((=value= (gensym)) + (=first= (gensym))) + `(with-html-output (*standard-output*) + (:p (:table :border 1 :cellpadding 2 :cellspacing 0 + (:tr (:td :colspan 2 + "Some Information " + (hunchentoot-link) + " provides about this request:")) + ,@(loop for form in forms + collect `(:tr (:td :valign "top" + (:pre :style "padding: 0px" + (esc (with-lisp-output (s) (pprint ',form s))))) + (:td :valign "top" + (:pre :style "padding: 0px" + (esc (with-lisp-output (s) + (loop for ,=value= in (multiple-value-list ,form) + for ,=first= = t then nil + unless ,=first= + do (princ ", " s) + do (pprint ,=value= s)))))))))) + (menu-link)))) + +(defun authorization-page () + (multiple-value-bind (user password) + (authorization) + (cond ((and (equal user "nanook") + (equal password "igloo")) + (with-html + (:html + (:head (:title "Hunchentoot page with Basic Authentication")) + (:body + (:h2 (hunchentoot-link) + " page with Basic Authentication") + (info-table (header-in "Authorization") + (authorization)))))) + (t + (require-authorization))))) + +(defparameter *test-image* + (load-time-value + (with-open-file (in (make-pathname :name "fz" :type "jpg" :version nil + :defaults *this-file*) + :element-type 'flex:octet) + (let ((image-data (make-array (file-length in) + :element-type 'flex:octet))) + (read-sequence image-data in) + image-data)))) + +(defun image-ram-page () + (setf (content-type) + "image/jpeg") + *test-image*) + +(let ((count 0)) + (defun info () + (with-html + (:html + (:head (:title "Hunchentoot Information")) + (:body + (:h2 (hunchentoot-link) " Information Page") + (:p "This page has been called " + (:b + (fmt "~[~;once~;twice~:;~:*~R times~]" (incf count))) + " since its handler was compiled.") + (info-table (host) + (server-address *server*) + (server-addr) + (server-port) + (remote-addr) + (remote-port) + (real-remote-addr) + (request-method) + (script-name) + (query-string) + (get-parameters) + (headers-in) + (cookies-in) + (user-agent) + (referer) + (request-uri) + (server-protocol) + (mod-lisp-id) + (ssl-session-id))))))) + +(defun oops () + (with-html + (dotimes (i 3) + (log-message* "Oops (default) # ~a" i)) + (log-message :emerg "Oops emergency") + (log-message :alert "Oops alert") + (log-message :crit "Oops critical") + (log-message :error "Oops error") + (log-message :warning "Oops warning") + (log-message :notice "Oops notice") + (log-message :info "Oops info") + (log-message :debug "Oops debug") + (error "An error was triggered on purpose. Check your ~ +Apache error log. Up to 12 messages where logged depending on ~ +the Apache log level set in httpd.conf.") + (:html + (:body "You'll never see this sentence...")))) + +(defun redir () + (redirect "/hunchentoot/test/info.html?redirected=1")) + +(defun forbidden () + (setf (return-code *reply*) +http-forbidden+) + nil) + +(defun cookie-test () + (set-cookie "pumpkin" :value "barking") + (no-cache) + (with-html + (:html + (:head (:title "Hunchentoot cookie test")) + (:body + (:h2 (hunchentoot-link) + " cookie test") + (:p "You might have to reload this page to see the cookie value.") + (info-table (cookie-in "pumpkin") + (mapcar #'car (cookies-in))))))) + +(defun session-test () + (let ((new-foo-value (post-parameter "new-foo-value"))) + (when new-foo-value + (setf (session-value 'foo) new-foo-value))) + (let ((new-bar-value (post-parameter "new-bar-value"))) + (when new-bar-value + (setf (session-value 'bar) new-bar-value))) + (no-cache) + (with-html + (:html + (:head (:title "Hunchentoot session test")) + (:body + (:h2 (hunchentoot-link) + " session test") + (:p "Use the forms below to set new values for " + (:code "FOO") + " or " + (:code "BAR") + ". You can later return to this page to check if +they're still set. Also, try to use another browser at the same +time or try with cookies disabled.") + (:p (:form :method :post + "New value for " + (:code "FOO") + ": " + (:input :type :text + :name "new-foo-value" + :value (or (session-value 'foo) "")))) + (:p (:form :method :post + "New value for " + (:code "BAR") + ": " + (:input :type :text + :name "new-bar-value" + :value (or (session-value 'bar) "")))) + (info-table *session-cookie-name* + (cookie-in *session-cookie-name*) + (mapcar #'car (cookies-in)) + (session-value 'foo) + (session-value 'bar)))))) + +(defun parameter-test (&key (method :get) (charset :iso-8859-1)) + (no-cache) + (recompute-request-parameters :external-format + (flex:make-external-format charset :eol-style :lf)) + (setf (content-type) + (format nil "text/html; charset=~A" charset)) + (with-html + (:html + (:head (:title (fmt "Hunchentoot ~A parameter test" method))) + (:body + (:h2 (hunchentoot-link) + (fmt " ~A parameter test with charset ~A" method charset)) + (:p "Enter some non-ASCII characters in the input field below +and see what's happening.") + (:p (:form + :method method + "Enter a value: " + (:input :type :text + :name "foo"))) + (case method + (:get (info-table (query-string) + (map 'list #'char-code (get-parameter "foo")) + (get-parameter "foo"))) + (:post (info-table (raw-post-data) + (map 'list #'char-code (post-parameter "foo")) + (post-parameter "foo")))))))) + +(defun parameter-test-latin1-get () + (parameter-test :method :get :charset :iso-8859-1)) + +(defun parameter-test-latin1-post () + (parameter-test :method :post :charset :iso-8859-1)) + +(defun parameter-test-utf8-get () + (parameter-test :method :get :charset :utf-8)) + +(defun parameter-test-utf8-post () + (parameter-test :method :post :charset :utf-8)) + +;; this should not be the same directory as *TMP-DIRECTORY* and it +;; should be initially empty (or non-existent) +(defvar *tmp-test-directory* + #+(or :win32 :mswindows) #p"c:\\hunchentoot-temp\\test\\" + #-(or :win32 :mswindows) #p"/tmp/hunchentoot/test/") + +(defvar *tmp-test-files* nil) + +(let ((counter 0)) + (defun handle-file (post-parameter) + (when (and post-parameter + (listp post-parameter)) + (destructuring-bind (path file-name content-type) + post-parameter + (let ((new-path (make-pathname :name (format nil "hunchentoot-test-~A" + (incf counter)) + :type nil + :defaults *tmp-test-directory*))) + ;; strip directory info sent by Windows browsers + (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*)))))) + +(defun clean-tmp-dir () + (loop for (path . nil) in *tmp-test-files* + when (probe-file path) + do (ignore-errors (delete-file path))) + (setq *tmp-test-files* nil)) + +(defun upload-test () + (let (post-parameter-p) + (when (post-parameter "file1") + (handle-file (post-parameter "file1")) + (setq post-parameter-p t)) + (when (post-parameter "file2") + (handle-file (post-parameter "file2")) + (setq post-parameter-p t)) + (when (post-parameter "clean") + (clean-tmp-dir) + (setq post-parameter-p t)) + (when post-parameter-p + ;; redirect so user can safely use 'Back' button + (redirect (script-name)))) + (no-cache) + (with-html + (:html + (:head (:title "Hunchentoot file upload test")) + (:body + (:h2 (hunchentoot-link) + " file upload test") + (:form :method :post :enctype "multipart/form-data" + (:p "First file: " + (:input :type :file + :name "file1")) + (:p "Second file: " + (:input :type :file + :name "file2")) + (:p (:input :type :submit))) + (when *tmp-test-files* + (htm + (:p + (:table :border 1 :cellpadding 2 :cellspacing 0 + (:tr (:td :colspan 3 (:b "Uploaded files"))) + (loop for (path file-name nil) in *tmp-test-files* + for counter from 1 + do (htm + (:tr (:td :align "right" (str counter)) + (:td (:a :href (format nil "files/~A?path=~A" + (url-encode file-name) + (url-encode (namestring path))) + (esc file-name))) + (:td :align "right" + (str (ignore-errors + (with-open-file (in path) + (file-length in)))) + " Bytes")))))) + (:form :method :post + (:p (:input :type :submit :name "clean" :value "Delete uploaded files"))))) + (menu-link))))) + +(defun send-file () + (let* ((path (get-parameter "path")) + (file-info (and path + (find (pathname path) *tmp-test-files* + :key #'first :test #'equal)))) + (unless file-info + (setf (return-code *reply*) + +http-not-found+) + (return-from send-file)) + (handle-static-file path (third file-info)))) + +(defparameter *headline* + (load-time-value + (format nil "Hunchentoot test menu (see file <code>~A</code>)" + (merge-pathnames (make-pathname :type "lisp") *this-file*)))) + +(defvar *utf-8* (flex:make-external-format :utf-8 :eol-style :lf)) + +(defvar *utf-8-file* (merge-pathnames "UTF-8-demo.html" *this-file*) + "Demo file stolen from <http://www.w3.org/2001/06/utf-8-test/>.") + +(defun stream-direct () + (setf (content-type) "text/html; charset=utf-8") + (let ((stream (send-headers)) + (buffer (make-array 1024 :element-type 'flex:octet))) + #+:clisp + (setf (flex:flexi-stream-element-type stream) 'flex:octet) + (with-open-file (in *utf-8-file* + :element-type 'flex:octet) + (loop for pos = (read-sequence buffer in) + until (zerop pos) + do (write-sequence buffer stream :end pos))))) + +(defun stream-direct-utf-8 () + (setf (content-type) "text/html; charset=utf-8") + (let ((stream (send-headers))) + (setf (flex:flexi-stream-external-format stream) *utf-8*) + (with-open-file (in (merge-pathnames "UTF-8-demo.html" *this-file*) + :element-type 'flex:octet) + (setq in (flex:make-flexi-stream in :external-format *utf-8*)) + (loop for line = (read-line in nil nil) + while line + do (write-line line stream))))) + +(defun stream-direct-utf-8-string () + (setf (content-type) "text/html; charset=utf-8" + (reply-external-format) *utf-8*) + (with-open-file (in (merge-pathnames "UTF-8-demo.html" *this-file*) + :element-type 'flex:octet) + (let ((string (make-array (file-length in) + :element-type #-:lispworks 'character #+:lispworks 'lw:simple-char + :fill-pointer t))) + (setf in (flex:make-flexi-stream in :external-format *utf-8*) + (fill-pointer string) (read-sequence string in)) + string))) + +(define-easy-handler (easy-demo :uri "/hunchentoot/test/easy-demo.html" + :default-request-type :post) + (first-name last-name + (age :parameter-type 'integer) + (implementation :parameter-type 'keyword) + (meal :parameter-type '(hash-table boolean)) + (team :parameter-type 'list)) + (with-html + (:html + (:head (:title "Hunchentoot \"easy\" handler example")) + (:body + (:h2 (hunchentoot-link) + " \"Easy\" handler example") + (:p (:form :method :post + (:table :border 1 :cellpadding 2 :cellspacing 0 + (:tr + (:td "First Name:") + (:td (:input :type :text + :name "first-name" + :value (or first-name "Donald")))) + (:tr + (:td "Last name:") + (:td (:input :type :text + :name "last-name" + :value (or last-name "Duck")))) + (:tr + (:td "Age:") + (:td (:input :type :text + :name "age" + :value (or age 42)))) + (:tr + (:td "Implementation:") + (:td (:select :name "implementation" + (loop for (value option) in '((:lispworks "LispWorks") + (:allegro "AllegroCL") + (:cmu "CMUCL") + (:sbcl "SBCL") + (:openmcl "OpenMCL")) + do (htm + (:option :value value + :selected (eq value implementation) + (str option))))))) + (:tr + (:td :valign :top "Meal:") + (:td (loop for choice in '("Burnt weeny sandwich" + "Canard du jour" + "Easy meat" + "Muffin" + "Twenty small cigars" + "Yellow snow") + do (htm + (:input :type "checkbox" + :name (format nil "meal{~A}" choice) + :checked (gethash choice meal) + (esc choice)) + (:br))))) + (:tr + (:td :valign :top "Team:") + (:td (loop for player in '("Beckenbauer" + "Cruyff" + "Maradona" + ;; without accent (for SBCL) + "Pele" + "Zidane") + do (htm + (:input :type "checkbox" + :name "team" + :value player + :checked (member player team :test #'string=) + (esc player)) + (:br))))) + (:tr + (:td :colspan 2 + (:input :type "submit")))))) + (info-table first-name + last-name + age + implementation + (loop :for choice :being :the :hash-keys :of meal :collect choice) + (gethash "Yellow snow" meal) + team))))) + + +(defun menu () + (with-html + (:html + (:head + (:link :rel "shortcut icon" + :href "/hunchentoot/test/favicon.ico" :type "image/x-icon") + (:title "Hunchentoot test menu")) + (:body + (:h2 (str *headline*)) + (:table :border 0 :cellspacing 4 :cellpadding 4 + (:tr (:td (:a :href "/hunchentoot/test/info.html?foo=bar" + "Info provided by Hunchentoot"))) + (:tr (:td (:a :href "/hunchentoot/test/cookie.html" + "Cookie test"))) + (:tr (:td (:a :href "/hunchentoot/test/session.html" + "Session test"))) + (:tr (:td (:a :href "/hunchentoot/test/parameter_latin1_get.html" + "GET parameter handling with LATIN-1 charset"))) + (:tr (:td (:a :href "/hunchentoot/test/parameter_latin1_post.html" + "POST parameter handling with LATIN-1 charset"))) + (:tr (:td (:a :href "/hunchentoot/test/parameter_utf8_get.html" + "GET parameter handling with UTF-8 charset"))) + (:tr (:td (:a :href "/hunchentoot/test/parameter_utf8_post.html" + "POST parameter handling with UTF-8 charset"))) + (:tr (:td (:a :href "/hunchentoot/test/redir.html" + "Redirect \(302) to info page above"))) + (:tr (:td (:a :href "/hunchentoot/test/authorization.html" + "Authorization") + " (user 'nanook', password 'igloo')")) + (:tr (:td (:a :href "/hunchentoot/code/test.lisp" + "The source code of this test"))) + (:tr (:td (:a :href "/hunchentoot/test/image.jpg" + "Binary data, delivered from file") + " \(a picture)")) + (:tr (:td (:a :href "/hunchentoot/test/image-ram.jpg" + "Binary data, delivered from RAM") + " \(same picture)")) + (:tr (:td (:a :href "/hunchentoot/test/easy-demo.html" + "\"Easy\" handler example"))) + (:tr (:td (:a :href "/hunchentoot/test/utf8-binary.txt" + "UTF-8 demo") + " \(writing octets directly to the stream)")) + (:tr (:td (:a :href "/hunchentoot/test/utf8-character.txt" + "UTF-8 demo") + " \(writing UTF-8 characters directly to the stream)")) + (:tr (:td (:a :href "/hunchentoot/test/utf8-string.txt" + "UTF-8 demo") + " \(returning a string)")) + (:tr (:td (:a :href "/hunchentoot/test/upload.html" + "File uploads"))) + (:tr (:td (:a :href "/hunchentoot/test/forbidden.html" + "Forbidden \(403) page"))) + (:tr (:td (:a :href "/hunchentoot/test/oops.html" + "Error handling") + " \(output depends on settings like " + (: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*) + ")")) + (:tr (:td (:a :href "/hunchentoot/foo" + "URI handled by") + " " + (:a :href "http://weitz.de/hunchentoot/#*default-handler*" + (:code "*DEFAULT-HANDLER*"))))))))) + +(setq *dispatch-table* + (nconc + (list 'dispatch-easy-handlers + (create-static-file-dispatcher-and-handler + "/hunchentoot/test/image.jpg" + (make-pathname :name "fz" :type "jpg" :version nil + :defaults *this-file*) + "image/jpeg") + (create-static-file-dispatcher-and-handler + "/hunchentoot/test/favicon.ico" + (make-pathname :name "favicon" :type "ico" :version nil + :defaults *this-file*)) + (create-folder-dispatcher-and-handler + "/hunchentoot/code/" + (make-pathname :name nil :type nil :version nil + :defaults *this-file*) + "text/plain")) + (mapcar (lambda (args) + (apply #'create-prefix-dispatcher args)) + '(("/hunchentoot/test/form-test.html" form-test) + ("/hunchentoot/test/forbidden.html" forbidden) + ("/hunchentoot/test/info.html" info) + ("/hunchentoot/test/authorization.html" authorization-page) + ("/hunchentoot/test/image-ram.jpg" image-ram-page) + ("/hunchentoot/test/cookie.html" cookie-test) + ("/hunchentoot/test/session.html" session-test) + ("/hunchentoot/test/parameter_latin1_get.html" parameter-test-latin1-get) + ("/hunchentoot/test/parameter_latin1_post.html" parameter-test-latin1-post) + ("/hunchentoot/test/parameter_utf8_get.html" parameter-test-utf8-get) + ("/hunchentoot/test/parameter_utf8_post.html" parameter-test-utf8-post) + ("/hunchentoot/test/upload.html" upload-test) + ("/hunchentoot/test/redir.html" redir) + ("/hunchentoot/test/oops.html" oops) + ("/hunchentoot/test/utf8-binary.txt" stream-direct) + ("/hunchentoot/test/utf8-character.txt" stream-direct-utf-8) + ("/hunchentoot/test/utf8-string.txt" stream-direct-utf-8-string) + ("/hunchentoot/test/files/" send-file) + ("/hunchentoot/test" menu))) + (list #'default-dispatcher))) Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-acl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-acl.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,53 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/unix-acl.lisp,v 1.5 2007/01/01 23:50:30 edi Exp $ + +;;; Copyright (c) 2004-2007, 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) + (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) + (error "Group ~S not found." name)))) Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-clisp.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-clisp.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,51 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10; -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/unix-clisp.lisp,v 1.1 2007/12/29 17:35:01 edi Exp $ + +;;; Copyright (c) 2006, Lu�s Oliveira <loliveira(a)common-lisp.net>. +;;; Copyright (c) 2007, Anton Vodonosov <avodonosov(a)yandex.ru>. +;;; Copyright (c) 2007, 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))) Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-cmu.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-cmu.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,54 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/unix-cmu.lisp,v 1.5 2007/01/01 23:50:30 edi Exp $ + +;;; Copyright (c) 2004-2007, 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)) + (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)) + (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))) Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-lw.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-lw.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,93 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/unix-lw.lisp,v 1.4 2007/01/01 23:50:30 edi Exp $ + +;;; Copyright (c) 2004-2007, 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)) + (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)) + (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) + (error "User ~S not found." name)) + (t (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) + (error "Group ~S not found." name)) + (t (error "getgrnam failed: ~A" (lw:get-unix-error errno)))))) + (fli:foreign-slot-value group 'gid))) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-mcl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-mcl.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,54 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/unix-mcl.lisp,v 1.6 2007/01/01 23:50:30 edi Exp $ + +;;; Copyright (c) 2004-2007, 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) + (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) + (error "setgid failed with errno ~A." errno)))) + +(defun get-uid-from-name (name) + "Returns the UID for the user named NAME." + (declare (ignore name)) + (error "GET-UID-FROM-NAME not yet implemented for OpenMCL. Please send patches...")) + +(defun get-gid-from-name (name) + "Returns the GID for the group named NAME." + (declare (ignore name)) + (error "GET-GID-FROM-NAME not yet implemented for OpenMCL. Please send patches...")) Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-sbcl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-sbcl.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,57 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/unix-sbcl.lisp,v 1.7 2007/10/06 22:44:06 edi Exp $ + +;;; Copyright (c) 2004-2007, 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 + (error "You need a version of SBCL with SB-POSIX:GETGRNAM \(1.0.10.31 or higher).")) Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/util.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/util.lisp Thu Feb 7 03:16:29 2008 @@ -0,0 +1,406 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/util.lisp,v 1.33 2007/12/29 17:35:02 edi Exp $ + +;;; Copyright (c) 2004-2007, 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) + +#-: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) + "Renaming LW:REBINDING for better indentation." + `(lw:rebinding ,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." + (let* ((length (length subseq)) + (mismatch (mismatch subseq seq + :test test))) + (or (null mismatch) + (<= length mismatch)))) + +(defun starts-with-one-of-p (seq subseq-list &key (test 'eql)) + "Tests whether the sequence SEQ starts with one of the +sequences in SUBSEQ-LIST. Individual elements are compared with +TEST." + (some (lambda (subseq) + (starts-with-p seq subseq :test test)) + subseq-list)) + +(defun create-random-string (&optional (n 10) (base 16)) + "Returns a random number \(as a string) with base BASE and N +digits." + (with-output-to-string (s) + (dotimes (i n) + (format s "~VR" base + (random base *the-random-state*))))) + +(defun reset-session-secret () + "Sets *SESSION-SECRET* to a new random value. All old sessions will +cease to be valid." + (setq *session-secret* (create-random-string 10 36))) + +(defun reason-phrase (return-code) + "Returns a reason phrase for the HTTP return code RETURN-CODE +\(which should be an integer) or NIL for return codes Hunchentoot +doesn't know." + (gethash return-code *http-reason-phrase-map*)) + +(defun make-keyword (string &key (destructivep t)) + "Interns the upcased version of STRING into the KEYWORD package. +Uses NSTRING-UPCASE if DESTRUCTIVEP is true. Returns NIL if STRING is +not a string." + (and (stringp string) + (intern (if destructivep + (nstring-upcase string) + (string-upcase string)) :keyword))) + +(defgeneric assoc (thing alist &key &allow-other-keys) + (:documentation "LIKE CL:ASSOC, but \'does the right thing\' if +THING is a string or a symbol.")) + +(defmethod assoc ((thing symbol) alist &key &allow-other-keys) + "Version of ASSOC for symbols, always uses EQ as test function." + (cl:assoc thing alist :test #'eq)) + +(defmethod assoc ((thing string) alist &key (test #'string-equal)) + "Version of ASSOC for strings, uses STRING-EQUAL as default test +function." + (cl:assoc thing alist :test test)) + +(defmethod assoc (thing alist &key (test #'eql)) + "Default method - uses EQL as default test like CL:ASSOC." + (cl:assoc thing alist :test test)) + +(defun md5-hex (string) + "Calculates the md5 sum of the string STRING and returns it as a hex string." + (with-output-to-string (s) + (loop for code across (md5:md5sum-sequence string) + do (format s "~2,'0x" code)))) + +(defun escape-for-html (string) + "Escapes the characters #\\<, #\\>, #\\', #\\\", and #\\& for HTML output." + (with-output-to-string (out) + (with-input-from-string (in string) + (loop for char = (read-char in nil nil) + while char + do (case char + ((#\<) (write-string "<" out)) + ((#\>) (write-string ">" out)) + ((#\") (write-string """ out)) + ((#\') (write-string "'" out)) + ((#\&) (write-string "&" out)) + (otherwise (write-char char out))))))) + +(defun http-token-p (token) + "Tests whether TOKEN is a string which is a valid 'token' +according to HTTP/1.1 \(RFC 2068)." + (and (stringp token) + (plusp (length token)) + (every (lambda (char) + (and ;; CHAR is US-ASCII but not control character or ESC + (< 31 (char-code char) 127) + ;; CHAR is not 'tspecial' + (not (find char "()<>@,;:\\\"/[]?={} " :test #'char=)))) + token))) + + +(defun rfc-1123-date (&optional (time (get-universal-time))) + "Generates a time string according to RFC 1123. Default is current time." + (multiple-value-bind + (second minute hour date month year day-of-week) + (decode-universal-time time 0) + (format nil "~A, ~2,'0d ~A ~4d ~2,'0d:~2,'0d:~2,'0d GMT" + (svref +day-names+ day-of-week) + date + (svref +month-names+ (1- month)) + year + hour + minute + second))) + +(defun iso-time (&optional (time (get-universal-time))) + "Returns the universal time TIME as a string in full ISO format." + (multiple-value-bind (second minute hour date month year) + (decode-universal-time time) + (format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d" + year month date hour minute second))) + +(let ((counter 0)) + (declare (ignorable counter)) + (defun make-tmp-file-name (&optional (prefix "hunchentoot")) + "Generates a unique name for a temporary file. This function is +called from the RFC2388 library when a file is uploaded." + (let ((tmp-file-name + #+:allegro + (pathname (system:make-temp-file-name prefix *tmp-directory*)) + #-:allegro + (loop for pathname = (make-pathname :name (format nil "~A-~A" + prefix (incf counter)) + :type nil + :defaults *tmp-directory*) + unless (probe-file pathname) + return pathname))) + (push tmp-file-name *tmp-files*) + ;; maybe call hook for file uploads + (when *file-upload-hook* + (funcall *file-upload-hook* tmp-file-name)) + tmp-file-name))) + +(defun quote-string (string) + "Quotes string according to RFC 2616's definition of `quoted-string'." + (with-output-to-string (out) + (with-input-from-string (in string) + (loop for char = (read-char in nil nil) + while char + unless (or (char< char #\Space) + (char= char #\Rubout)) + do (case char + ((#\\) (write-string "\\\\" out)) + ((#\") (write-string "\\\"" out)) + (otherwise (write-char char out))))))) + +(defun url-decode (string &optional (external-format *hunchentoot-default-external-format*)) + "Decodes a URL-encoded STRING which is assumed to be encoded using +the external format EXTERNAL-FORMAT." + (let ((vector (make-array (length string) + :element-type 'octet + :fill-pointer 0))) + (loop with percent-p and buff + for char of-type character across string + for i from 0 + when buff do + (vector-push (parse-integer string + :start (1- i) + :end (1+ i) + :radix 16) + vector) + (setq buff nil) + else when percent-p + do (setq buff t + percent-p nil) + else when (char= char #\%) + do (setq percent-p t) + else do (vector-push (char-code (case char + ((#\+) #\Space) + (otherwise char))) + vector)) + (octets-to-string vector :external-format external-format))) + +(defun form-url-encoded-list-to-alist (form-url-encoded-list + &optional (external-format *hunchentoot-default-external-format*)) + "Converts a list FORM-URL-ENCODED-LIST of name/value pairs into an +alist. Both names and values are url-decoded while doing this." + (mapcar #'(lambda (entry) + (destructuring-bind (name &optional value) + (split "=" entry :limit 2) + (cons (string-trim " " (url-decode name external-format)) + (url-decode (or value "") external-format)))) + form-url-encoded-list)) + +(defun url-encode (string &optional (external-format *hunchentoot-default-external-format*)) + "URL-encodes a string using the external format EXTERNAL-FORMAT." + (with-output-to-string (s) + (loop for c across string + for index from 0 + do (cond ((or (char<= #\0 c #\9) + (char<= #\a c #\z) + (char<= #\A c #\Z) + ;; note that there's no comma in there - because of cookies + (find c "$-_.!*'()" :test #'char=)) + (write-char c s)) + (t (loop for octet across (string-to-octets string + :start index + :end (1+ index) + :external-format external-format) + do (format s "%~2,'0x" octet))))))) + +(defun force-output* (stream) + "Like FORCE-OUTPUT but aborts execution after +*FORCE-OUTPUT-TIMEOUT* seconds." + (with-timeout (*force-output-timeout* + (warn "FORCE-OUTPUT didn't return after ~A seconds." + *force-output-timeout*)) + (force-output stream))) + +(defun parse-content-type (content-type-header &optional want-external-format-p) + "Reads and parses a `Content-Type' header and returns it as three +values - the type, the subtype, and an external format corresponding +to the 'charset' parameter in the header \(or +*HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*), if there is one and if the +content type is \"text\" or WANT-EXTERNAL-FORMAT-P is true. +CONTENT-TYPE-HEADER is supposed to be the corresponding header value +as a string." + (with-input-from-string (stream content-type-header) + (let* ((*current-error-message* "Corrupted Content-Type header:") + (type (read-token stream)) + (subtype (and (or (ignore-errors (assert-char stream #\/)) + (return-from parse-content-type + ;; try to return something meaningful + (values "application" "octet-stream" + (and want-external-format-p + *hunchentoot-default-external-format*)))) + (read-token stream))) + (parameters (read-name-value-pairs stream)) + (charset (cdr (assoc "charset" parameters))) + (external-format + (and (or want-external-format-p + (string-equal type "text")) + (or (when charset + (handler-case + (make-external-format (make-keyword charset) :eol-style :lf) + (error (condition) + (warn "Ignoring external format of name ~S~ +because of error:~%~A" + charset condition)))) + *hunchentoot-default-external-format*)))) + (values type subtype external-format)))) + +(defun get-token-and-parameters (header) + (with-input-from-string (stream header) + (let* ((*current-error-message* (format nil "Corrupted header ~S:" header)) + (token (read-token stream)) + (parameters (read-name-value-pairs stream))) + (values token parameters)))) + +(defun keep-alive-p () + "Returns a true value unless the incoming request obviates a +keep-alive reply. The second return value denotes whether the client +has explicitly asked for a persistent connection." + (let ((connection-values + ;; the header might consist of different values separated by commas + (when-let (connection-header (header-in :connection)) + (split "\\s*,\\s*" connection-header)))) + (flet ((connection-value-p (value) + "Checks whether the string VALUE is one of the +values of the `Connection' header." + (member value connection-values :test #'string-equal))) + (let ((keep-alive-requested-p (connection-value-p "keep-alive"))) + (values (and (or (and (eq (server-protocol) :http/1.1) + (not (connection-value-p "close"))) + (and (eq (server-protocol) :http/1.0) + keep-alive-requested-p))) + keep-alive-requested-p))))) + +(defun address-string () + "Returns a string with information about Hunchentoot suitable for +inclusion in HTML output." + (format nil "<address>~:[~3*~;<a href='http://httpd.apache.org/'>~A</a> / <a href='http://www.fractalconcept.com/asp/html/mod_lisp.html'>mod_lisp~A~@[/~A~]</a> / ~]<a href='http://weitz.de/hunchentoot/'>Hunchentoot ~A</a> <a href='~A'>(~A ~A)</a>~@[ at ~A~:[ (port ~D)~;~]~]</address>" + (server-mod-lisp-p *server*) + (or (header-in :server-baseversion) "Apache") + (or (header-in :modlisp-major-version) "") + (header-in :modlisp-version) + *hunchentoot-version* + +implementation-link+ + (escape-for-html (lisp-implementation-type)) + (escape-for-html (lisp-implementation-version)) + (or (host *request*) (server-address *server*)) + (scan ":\\d+$" (or (host *request*) "")) + (server-port))) + +(defun server-name-header () + "Returns a string which can be used for 'Server' headers." + (format nil "Hunchentoot ~A" *hunchentoot-version*)) + +(defun input-chunking-p () + "Whether input chunking is currently switched on for \(the socket +stream underlying) *HUNCHENTOOT-STREAM* - note that this will return +NIL if the underlying stream of the flexi stream is not a chunked +stream." + (chunked-stream-input-chunking-p (flexi-stream-stream *hunchentoot-stream*))) + +(defun cleanup-function () + "The default for *CLEANUP-FUNCTION*. Invokes a GC on 32-bit +LispWorks and does nothing on other Lisps." + #+(and :lispworks (not :lispworks-64bit)) + (hcl:mark-and-sweep 2))

1 0

[bknr-cvs] r2448 - trunk/projects/lisp-ecoop/website/templates
by hhubner＠common-lisp.net 06 Feb '08

06 Feb '08

Author: hhubner Date: Wed Feb 6 08:55:33 2008 New Revision: 2448 Modified: trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl trunk/projects/lisp-ecoop/website/templates/toplevel.xml Log: Add link to top-level ELW directory Modified: trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl (original) +++ trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl Wed Feb 6 08:55:33 2008 @@ -33,6 +33,11 @@ <xsl:call-template name="menu"> <xsl:with-param name="current" select="@name"/> </xsl:call-template> + <div class="site-menu"> + <div class="site-menu-inactive"> + <a href="/">ELW Home</a> + </div> + </div> </div> <div id="content"> <xsl:copy-of select="." /> Modified: trunk/projects/lisp-ecoop/website/templates/toplevel.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/toplevel.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/toplevel.xml Wed Feb 6 08:55:33 2008 @@ -41,6 +41,11 @@ <div id="login"> <lisp-ecoop:login-widget /> </div> + <div class="site-menu"> + <div class="site-menu-inactive"> + <a href="/">ELW Home</a> + </div> + </div> </div> <div id="content"> <bknr:tag-body />

1 0

[bknr-cvs] r2447 - trunk/projects/lisp-ecoop/website/templates
by hhubner＠common-lisp.net 06 Feb '08

06 Feb '08

Author: hhubner Date: Wed Feb 6 07:08:44 2008 New Revision: 2447 Modified: trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl trunk/projects/lisp-ecoop/website/templates/toplevel.xml Log: Add Google Analytics tracking to site. Modified: trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl (original) +++ trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl Wed Feb 6 07:08:44 2008 @@ -38,6 +38,15 @@ <xsl:copy-of select="." /> </div> </div> +<script type="text/javascript"> +var gaJsHost = (("https:" == document.location.protocol) ? "https://ssl." : "http://www."); +document.write(unescape("%3Cscript src='" + gaJsHost + "google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E")); +</script> +<script type="text/javascript"> +var pageTracker = _gat._getTracker("UA-3432041-2"); +pageTracker._initData(); +pageTracker._trackPageview(); +</script> </body> </html> </xsl:template> Modified: trunk/projects/lisp-ecoop/website/templates/toplevel.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/toplevel.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/toplevel.xml Wed Feb 6 07:08:44 2008 @@ -47,5 +47,14 @@ <hr class="content-rule"/> </div> </div> +<script type="text/javascript"> +var gaJsHost = (("https:" == document.location.protocol) ? "https://ssl." : "http://www."); +document.write(unescape("%3Cscript src='" + gaJsHost + "google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E")); +</script> +<script type="text/javascript"> +var pageTracker = _gat._getTracker("UA-3432041-2"); +pageTracker._initData(); +pageTracker._trackPageview(); +</script> </body> </html>

1 0

[bknr-cvs] r2446 - trunk/projects/lisp-ecoop/website/templates
by hhubner＠common-lisp.net 06 Feb '08

06 Feb '08

Author: hhubner Date: Wed Feb 6 06:37:33 2008 New Revision: 2446 Modified: trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl Log: Change path to logo. Modified: trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl (original) +++ trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl Wed Feb 6 06:37:33 2008 @@ -24,7 +24,7 @@ <div id="subtitle">Co-located with <a href="http://2008.ecoop.org/" target="_new">ECOOP 2008</a> July 07 - Paphos-Cyprus</div> <div id="logo"> <a href="http://bknr.net/" target="_new"> - <img width="57" height="20" alt="BKNR Logo" src="/image/bknr-logo/thumbnail,,57,20" border="0" /> + <img width="57" height="20" alt="BKNR Logo" src="/static/bknr-logo.png" border="0" /> </a> </div> </div>

1 0

[bknr-cvs] r2445 - trunk/projects/lisp-ecoop/website/templates
by dverna＠common-lisp.net 06 Feb '08

06 Feb '08

Author: dverna Date: Wed Feb 6 06:29:25 2008 New Revision: 2445 Modified: trunk/projects/lisp-ecoop/website/templates/contact.xml trunk/projects/lisp-ecoop/website/templates/home.xml trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl trunk/projects/lisp-ecoop/website/templates/news.xml trunk/projects/lisp-ecoop/website/templates/people.xml trunk/projects/lisp-ecoop/website/templates/programme.xml trunk/projects/lisp-ecoop/website/templates/submissions.xml trunk/projects/lisp-ecoop/website/templates/toplevel.xml Log: First shot at the 2008 website Modified: trunk/projects/lisp-ecoop/website/templates/contact.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/contact.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/contact.xml Wed Feb 6 06:29:25 2008 @@ -9,27 +9,35 @@ <ul> -<li>Pascal Costanza, <a -href="http://p-cos.net">http://p-cos.net</a>, -Vrije Universiteit Brussel, Belgium (contact organizer)</li> - -<li>Theo D'Hondt, <a -href="http://prog.vub.ac.be/~tjdhondt">http://prog.vub.ac.be/~tjdhondt</a>, -Vrije Universiteit Brussel, Belgium</li> +<li> +Didier Verna, +<a href="http://www.lrde.epita.fr/~didier"> +http://www.lrde.epita.fr/~didier +</a>, +EPITA Research and Development Laboratory, Paris, France (contact organizer) +</li> +<li> +Charlotte Herzeel, Programming Technology Lab, Vrije Universiteit, Brussel, +Belgium +</li> +<li> +Christophe Rhodes, +<a href="http://www.doc.gold.ac.uk/~mas01cr/"> +http://www.doc.gold.ac.uk/~mas01cr/ +</a>, +Goldsmiths College, University of London, United Kingdom +</li> <li>Hans Hübner, Software Developer, Berlin, Germany</li> -<li>Arthur Lemmens, Independent Consultant, Amsterdam, The -Netherlands</li> - -<li>Christophe Rhodes, <a -href="http://www.doc.gold.ac.uk/~mas01cr/">http://www.doc.gold.ac.uk/~mas01cr/</a>, -Goldsmiths College, University of London, United Kingdom</li> </ul> <h1>Contact</h1> - Workshop related: <a href="mailto:pc@p-cos.net">Pascal Costanza</a> + + Workshop related: + <a href="mailto:didier@lrde.epita.fr">Didier Verna</a> + Website related: <a href="mailto:hans@bknr.net">Hans Hübner</a> </lisp-ecoop:page> Modified: trunk/projects/lisp-ecoop/website/templates/home.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/home.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/home.xml Wed Feb 6 06:29:25 2008 @@ -3,71 +3,86 @@ <lisp-ecoop:page name="home" xmlns:lisp-ecoop="http://elw.bknr.net/"> -<h1>4th European Lisp Workshop</h1> +<h1>5th European Lisp Workshop</h1> -July 30 - Berlin, Germany - co-located with ECOOP 2007 +July 07 - Paphos-Cyprus - co-located with ECOOP 2008 -Supported by <a href="http://clozure.com/" target="_new">Clozure Associates</a> + + + + <h2>Important Dates</h2> <ul> -<li>Submission deadline: May 31, 2007</li> -<li>Notification of acceptance: June 8, 2007</li> -<li>ECOOP early registration deadline: June 15, 2007</li> +<li>Submission deadline: May 18, 2008</li> +<li>Notification of acceptance: June 08, 2008</li> +<li>ECOOP early registration deadline: June 15, 2008</li> </ul> <h2>Overview</h2> <blockquote> -...Please don't assume Lisp is only useful for Animation and Graphics, -AI, Bioinformatics, B2B and E-Commerce, Data Mining, EDA/Semiconductor +...Please don't assume Lisp is only useful for Animation and Graphics, AI, +Bioinformatics, B2B and E-Commerce, Data Mining, EDA/Semiconductor applications, Expert Systems, Finance, Intelligent Agents, Knowledge Management, Mechanical CAD, Modeling and Simulation, Natural Language, -Optimization, Research, Risk Analysis, Scheduling, Telecom, and Web -Authoring just because these are the only things they happened to -list. -- Kent Pitman +Optimization, Research, Risk Analysis, Scheduling, Telecom, and Web Authoring +just because these are the only things they happened to list. -- Kent Pitman </blockquote> -Lisp is one of the oldest computer languages still in use today. In -the decades of its existence, Lisp has been a fruitful basis for -language design experiments as well as the preferred implementation -language for applications in diverse fields. - -The structure of Lisp makes it easy to extend the language or even to -implement entirely new dialects without starting from scratch. Common -Lisp, with the Common Lisp Object System (CLOS), was the first -object-oriented programming language to receive an ANSI standard and -retains the most complete and advanced object system of any -programming language, while influencing many other object-oriented -programming languages that followed. - -It is clear that Lisp is gaining momentum: there is a -steadily growing interest in Lisp itself, with numerous user groups -in existence worldwide, and in Lisp's metaprogramming notions -which are being transferred to other languages, as -for example in Aspect-Oriented Programming, support for -Domain-Specific Languages, and so on. - -This workshop will address the near-future role of Lisp-based -languages in research, industry and education. We solicit -papers and suggestions for breakout groups that discuss the -opportunities Lisp provides to capture and enhance the possibilities -in software engineering. We want to promote lively discussion -between researchers proposing new approaches and practitioners -reporting on their experience with the strengths and limitations of -current Lisp technologies. - -The workshop will have two components; there will -be formally-presented talks, and breakout groups -discussing or working on particular topics. Additionally, there -will be opportunities for short, informal talks and demonstrations on -experience reports, underappreciated results, software under -development, or other topics of interest. + +Lisp is one of the oldest computer languages still in use today. In the +decades of its existence, Lisp has been a fruitful basis for language design +experiments as well as the preferred implementation language for applications +in diverse fields. + + + +The structure of Lisp makes it easy to extend the language or even to +implement entirely new dialects without starting from scratch. Common Lisp, +with the Common Lisp Object System (CLOS), was the first object-oriented +programming language to receive an ANSI standard and retains the most complete +and advanced object system of any programming language, while influencing many +other object-oriented programming languages that followed. + + + +It is clear that Lisp is gaining momentum: there is a steadily growing +interest in Lisp itself, with numerous user groups in existence worldwide, and +in Lisp's metaprogramming notions which are being transferred to other +languages, as for example in Aspect-Oriented Programming, support for +Domain-Specific Languages, and so on. + + + +This workshop will address the near-future role of Lisp-based languages in +research, industry and education. We solicit papers and suggestions for +breakout groups that discuss the opportunities Lisp provides to capture and +enhance the possibilities in software engineering. We want to promote lively +discussion between researchers proposing new approaches and practitioners +reporting on their experience with the strengths and limitations of current +Lisp technologies. + + + +The workshop will have two components; there will be formally-presented talks, +and breakout groups discussing or working on particular topics. Additionally, +there will be opportunities for short, informal talks and demonstrations on +experience reports, underappreciated results, software under development, or +other topics of interest. + </lisp-ecoop:page> Modified: trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl (original) +++ trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl Wed Feb 6 06:29:25 2008 @@ -20,8 +20,8 @@ </head> <body> <div id="banner"> - <div id="title">4th European Lisp Workshop</div> - <div id="subtitle">Co-located with <a href="http://2008.ecoop.org/" target="_new">ECOOP 2008</a> July 30 - Berlin - Germany</div> + <div id="title">5th European Lisp Workshop</div> + <div id="subtitle">Co-located with <a href="http://2008.ecoop.org/" target="_new">ECOOP 2008</a> July 07 - Paphos-Cyprus</div> <div id="logo"> <a href="http://bknr.net/" target="_new"> <img width="57" height="20" alt="BKNR Logo" src="/image/bknr-logo/thumbnail,,57,20" border="0" /> Modified: trunk/projects/lisp-ecoop/website/templates/news.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/news.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/news.xml Wed Feb 6 06:29:25 2008 @@ -5,6 +5,7 @@ <h1>News</h1> + -<h3>March 30, 2007</h3> +<h3>February 06, 2008</h3> <ul> <li>Launched the workshop website.</li> Modified: trunk/projects/lisp-ecoop/website/templates/people.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/people.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/people.xml Wed Feb 6 06:29:25 2008 @@ -5,8 +5,10 @@ <h1>People</h1> -The following people have registered to the workshop. Please click -on a person's name to get further information + +The following people have registered to the workshop. Please click on a +person's name to get further information. + <lisp-ecoop:participant-list /> Modified: trunk/projects/lisp-ecoop/website/templates/programme.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/programme.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/programme.xml Wed Feb 6 06:29:25 2008 @@ -5,6 +5,9 @@ <h1>Workshop Programme</h1> +The programme will be available by the end of June. + + </lisp-ecoop:page> Modified: trunk/projects/lisp-ecoop/website/templates/submissions.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/submissions.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/submissions.xml Wed Feb 6 06:29:25 2008 @@ -5,7 +5,9 @@ <h1>Submissions</h1> -We have accepted the following submissions. + + +The list of accepted submissions will be available by the end of June. <h2>Papers</h2> <lisp-ecoop:submission-list type="paper"/> Modified: trunk/projects/lisp-ecoop/website/templates/toplevel.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/toplevel.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/toplevel.xml Wed Feb 6 06:29:25 2008 @@ -8,43 +8,43 @@ xmlns:menu="http://bknr.net/menu" > <head> - <title>LISP-ECOOP07 - $(title)</title> + <title>LISP-ECOOP08 - $(title)</title> <link rel="stylesheet" type="text/css" href="$(base)static/styles.css" /> <script src="$(base)static/javascript.js" language="javascript" type="text/javascript"> </script> </head> <body> <div id="banner"> - <div id="title">4th European Lisp Workshop</div> - <div id="subtitle">Co-located with <a href="http://2007.ecoop.org/" target="_new">ECOOP 2007</a> July 30 - Berlin - Germany</div> + <div id="title">5th European Lisp Workshop</div> + <div id="subtitle">Co-located with <a href="http://2008.ecoop.org/" target="_new">ECOOP 2008</a> July 07 - Paphos-Cyprus</div> <div id="logo"> - <a href="http://bknr.net/" target="_new"> + <a href="http://bknr.net/" target="_new"> <img width="57" height="20" alt="BKNR Logo" src="$(base)image/bknr-logo/thumbnail,,57,20" border="0" /> </a> </div> </div> <div id="body"> <div id="system-column"> - <menu:site-menu config="menu.xml" - menu-name="main" + <menu:site-menu config="menu.xml" + menu-name="main" container-class="site-menu" - active-class="site-menu-active" - inactive-class="site-menu-inactive" /> - <lisp-ecoop:admin-only> - <menu:site-menu config="admin-menu.xml" - menu-name="admin" - title="Admin" + active-class="site-menu-active" + inactive-class="site-menu-inactive" /> + <lisp-ecoop:admin-only> + <menu:site-menu config="admin-menu.xml" + menu-name="admin" + title="Admin" container-class="site-menu" - active-class="site-menu-active" - inactive-class="site-menu-inactive" /> - </lisp-ecoop:admin-only> - <div id="login"> - <lisp-ecoop:login-widget /> - </div> + active-class="site-menu-active" + inactive-class="site-menu-inactive" /> + </lisp-ecoop:admin-only> + <div id="login"> + <lisp-ecoop:login-widget /> + </div> </div> <div id="content"> - <bknr:tag-body /> - <hr class="content-rule"/> + <bknr:tag-body /> + <hr class="content-rule"/> </div> </div> </body>

1 0

[bknr-cvs] r2444 - trunk/projects/lisp-ecoop/website/templates
by hhubner＠common-lisp.net 05 Feb '08

05 Feb '08

Author: hhubner Date: Tue Feb 5 16:15:52 2008 New Revision: 2444 Modified: trunk/projects/lisp-ecoop/website/templates/add-participant.xml trunk/projects/lisp-ecoop/website/templates/contact.xml trunk/projects/lisp-ecoop/website/templates/create-submission.xml trunk/projects/lisp-ecoop/website/templates/edit-profile.xml trunk/projects/lisp-ecoop/website/templates/edit-submission-submitters.xml trunk/projects/lisp-ecoop/website/templates/edit-submission.xml trunk/projects/lisp-ecoop/website/templates/groups.xml trunk/projects/lisp-ecoop/website/templates/guidelines.xml trunk/projects/lisp-ecoop/website/templates/home.xml trunk/projects/lisp-ecoop/website/templates/login.xml trunk/projects/lisp-ecoop/website/templates/news.xml trunk/projects/lisp-ecoop/website/templates/papers.xml trunk/projects/lisp-ecoop/website/templates/people.xml trunk/projects/lisp-ecoop/website/templates/profile.xml trunk/projects/lisp-ecoop/website/templates/programme.xml trunk/projects/lisp-ecoop/website/templates/registration.xml trunk/projects/lisp-ecoop/website/templates/schedule.xml trunk/projects/lisp-ecoop/website/templates/submission.xml trunk/projects/lisp-ecoop/website/templates/submissions.xml trunk/projects/lisp-ecoop/website/templates/toplevel.xml trunk/projects/lisp-ecoop/website/templates/upload.xml trunk/projects/lisp-ecoop/website/templates/user-error.xml Log: change namespace url to what we use now Modified: trunk/projects/lisp-ecoop/website/templates/add-participant.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/add-participant.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/add-participant.xml Tue Feb 5 16:15:52 2008 @@ -1,7 +1,7 @@ <?xml version="1.0" encoding="UTF-8"?> <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?> <lisp-ecoop:page name="login" - xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net"> + xmlns:lisp-ecoop="http://elw.bknr.net/"> <h1>Add Participant</h1> Modified: trunk/projects/lisp-ecoop/website/templates/contact.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/contact.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/contact.xml Tue Feb 5 16:15:52 2008 @@ -1,7 +1,7 @@ <?xml version="1.0" encoding="UTF-8"?> <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?> <lisp-ecoop:page name="contact" - xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net"> + xmlns:lisp-ecoop="http://elw.bknr.net/"> <h1>Organizing Committee</h1> Modified: trunk/projects/lisp-ecoop/website/templates/create-submission.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/create-submission.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/create-submission.xml Tue Feb 5 16:15:52 2008 @@ -2,7 +2,7 @@ <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> <html - xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net"> + xmlns:lisp-ecoop="http://elw.bknr.net/"> <head> <title>Create submission</title> <link rel="stylesheet" type="text/css" href="/static/document-utils.css" /> Modified: trunk/projects/lisp-ecoop/website/templates/edit-profile.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/edit-profile.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/edit-profile.xml Tue Feb 5 16:15:52 2008 @@ -2,7 +2,7 @@ <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> <lisp-ecoop:page name="edit profile" - xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net"> + xmlns:lisp-ecoop="http://elw.bknr.net/"> <h1>Participant Profile Editor</h1> Modified: trunk/projects/lisp-ecoop/website/templates/edit-submission-submitters.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/edit-submission-submitters.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/edit-submission-submitters.xml Tue Feb 5 16:15:52 2008 @@ -2,7 +2,7 @@ <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> <html - xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net"> + xmlns:lisp-ecoop="http://elw.bknr.net/"> <head> <title>Edit Submitter List</title> </head> Modified: trunk/projects/lisp-ecoop/website/templates/edit-submission.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/edit-submission.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/edit-submission.xml Tue Feb 5 16:15:52 2008 @@ -2,7 +2,7 @@ <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> <lisp-ecoop:page name="edit submission" - xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net"> + xmlns:lisp-ecoop="http://elw.bknr.net/"> <h1>Submission Editor</h1> Modified: trunk/projects/lisp-ecoop/website/templates/groups.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/groups.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/groups.xml Tue Feb 5 16:15:52 2008 @@ -1,7 +1,7 @@ <?xml version="1.0" encoding="UTF-8"?> <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?> <lisp-ecoop:page name="groups" - xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net"> + xmlns:lisp-ecoop="http://elw.bknr.net/"> <h1>Breakout Groups</h1> Modified: trunk/projects/lisp-ecoop/website/templates/guidelines.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/guidelines.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/guidelines.xml Tue Feb 5 16:15:52 2008 @@ -1,7 +1,7 @@ <?xml version="1.0" encoding="UTF-8"?> <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?> <lisp-ecoop:page name="guidelines" - xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net"> + xmlns:lisp-ecoop="http://elw.bknr.net/"> <h1>Submission Guidelines</h1> Modified: trunk/projects/lisp-ecoop/website/templates/home.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/home.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/home.xml Tue Feb 5 16:15:52 2008 @@ -1,7 +1,7 @@ <?xml version="1.0" encoding="UTF-8"?> <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?> <lisp-ecoop:page name="home" - xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net"> + xmlns:lisp-ecoop="http://elw.bknr.net/"> <h1>4th European Lisp Workshop</h1> @@ -12,7 +12,7 @@ <h2>Important News</h2> <ul> <li>The workshop programme is now online.</li> -<li><a href="http://lisp-ecoop07.bknr.net/profile/5802">Alexander Repenning</a> will be giving a keynote presentation about <a href="http://lisp-ecoop07.bknr.net/submission/5881">Antiobjects: Mapping Game AI to Massively Parallel Architectures using Collaborative Diffusion</a>.</li> +<li><a href="http://elw.bknr.net//profile/5802">Alexander Repenning</a> will be giving a keynote presentation about <a href="http://lisp-ecoop07.bknr.net/submission/5881">Antiobjects: Mapping Game AI to Massively Parallel Architectures using Collaborative Diffusion</a>.</li> </ul> <h2>Important Dates</h2> Modified: trunk/projects/lisp-ecoop/website/templates/login.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/login.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/login.xml Tue Feb 5 16:15:52 2008 @@ -1,7 +1,7 @@ <?xml version="1.0" encoding="UTF-8"?> <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?> <lisp-ecoop:page name="login" - xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net"> + xmlns:lisp-ecoop="http://elw.bknr.net/"> <h1>Login</h1> Modified: trunk/projects/lisp-ecoop/website/templates/news.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/news.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/news.xml Tue Feb 5 16:15:52 2008 @@ -1,7 +1,7 @@ <?xml version="1.0" encoding="UTF-8"?> <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?> <lisp-ecoop:page name="news" - xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net"> + xmlns:lisp-ecoop="http://elw.bknr.net/"> <h1>News</h1> @@ -14,7 +14,7 @@ <h3>May 17, 2007</h3> <ul> -<li><a href="http://lisp-ecoop07.bknr.net/profile/5802">Alexander Repenning</a> will be giving a keynote presentation about <a href="http://lisp-ecoop07.bknr.net/submission/5881">Antiobjects: Mapping Game AI to Massively Parallel Architectures using Collaborative Diffusion</a>.</li> +<li><a href="http://elw.bknr.net//profile/5802">Alexander Repenning</a> will be giving a keynote presentation about <a href="http://lisp-ecoop07.bknr.net/submission/5881">Antiobjects: Mapping Game AI to Massively Parallel Architectures using Collaborative Diffusion</a>.</li> <li>The submission deadline for papers, essays and breakout group proposals has been extended to May 31.</li> </ul> Modified: trunk/projects/lisp-ecoop/website/templates/papers.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/papers.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/papers.xml Tue Feb 5 16:15:52 2008 @@ -1,7 +1,7 @@ <?xml version="1.0" encoding="UTF-8"?> <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?> <lisp-ecoop:page name="papers" - xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net"> + xmlns:lisp-ecoop="http://elw.bknr.net/"> <h1>Papers</h1> Modified: trunk/projects/lisp-ecoop/website/templates/people.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/people.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/people.xml Tue Feb 5 16:15:52 2008 @@ -1,7 +1,7 @@ <?xml version="1.0" encoding="UTF-8"?> <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?> <lisp-ecoop:page name="people" - xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net"> + xmlns:lisp-ecoop="http://elw.bknr.net/"> <h1>People</h1> Modified: trunk/projects/lisp-ecoop/website/templates/profile.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/profile.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/profile.xml Tue Feb 5 16:15:52 2008 @@ -2,7 +2,7 @@ <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> <lisp-ecoop:page name="participant profile" - xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net"> + xmlns:lisp-ecoop="http://elw.bknr.net/"> <lisp-ecoop:profile> <h1>Participant Profile</h1> Modified: trunk/projects/lisp-ecoop/website/templates/programme.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/programme.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/programme.xml Tue Feb 5 16:15:52 2008 @@ -1,7 +1,7 @@ <?xml version="1.0" encoding="UTF-8"?> <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?> <lisp-ecoop:page name="programme" - xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net"> + xmlns:lisp-ecoop="http://elw.bknr.net/"> <h1>Workshop Programme</h1> Modified: trunk/projects/lisp-ecoop/website/templates/registration.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/registration.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/registration.xml Tue Feb 5 16:15:52 2008 @@ -1,7 +1,7 @@ <?xml version="1.0" encoding="UTF-8"?> <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?> <lisp-ecoop:page name="registration" - xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net"> + xmlns:lisp-ecoop="http://elw.bknr.net/"> <h1>Registration</h1> Modified: trunk/projects/lisp-ecoop/website/templates/schedule.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/schedule.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/schedule.xml Tue Feb 5 16:15:52 2008 @@ -1,7 +1,7 @@ <?xml version="1.0" encoding="UTF-8"?> <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?> <lisp-ecoop:page name="schedule" - xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net"> + xmlns:lisp-ecoop="http://elw.bknr.net/"> <lisp-ecoop:admin-only> <lisp-ecoop:schedule-submission /> Modified: trunk/projects/lisp-ecoop/website/templates/submission.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/submission.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/submission.xml Tue Feb 5 16:15:52 2008 @@ -2,7 +2,7 @@ <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> <lisp-ecoop:page name="submission" - xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net"> + xmlns:lisp-ecoop="http://elw.bknr.net/"> <lisp-ecoop:load-argument-object> <h1>$(title)</h1> Modified: trunk/projects/lisp-ecoop/website/templates/submissions.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/submissions.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/submissions.xml Tue Feb 5 16:15:52 2008 @@ -1,7 +1,7 @@ <?xml version="1.0" encoding="UTF-8"?> <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?> <lisp-ecoop:page name="submissions" - xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net"> + xmlns:lisp-ecoop="http://elw.bknr.net/"> <h1>Submissions</h1> Modified: trunk/projects/lisp-ecoop/website/templates/toplevel.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/toplevel.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/toplevel.xml Tue Feb 5 16:15:52 2008 @@ -3,7 +3,7 @@ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> <html xmlns="http://www.w3.org/1999/xhtml" - xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net" + xmlns:lisp-ecoop="http://elw.bknr.net/" xmlns:bknr="http://bknr.net" xmlns:menu="http://bknr.net/menu" > Modified: trunk/projects/lisp-ecoop/website/templates/upload.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/upload.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/upload.xml Tue Feb 5 16:15:52 2008 @@ -2,7 +2,7 @@ <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> <html - xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net"> + xmlns:lisp-ecoop="http://elw.bknr.net/"> <head> <title>Upload document</title> <link rel="stylesheet" type="text/css" href="/static/document-utils.css" /> Modified: trunk/projects/lisp-ecoop/website/templates/user-error.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/user-error.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/user-error.xml Tue Feb 5 16:15:52 2008 @@ -4,7 +4,7 @@ <html xmlns="http://www.w3.org/1999/xhtml" xmlns:bknr="http://bknr.net" - xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net" + xmlns:lisp-ecoop="http://elw.bknr.net/" xmlns:menu="http://bknr.net/menu" > <head>

1 0

[bknr-cvs] r2443 - trunk/projects/lisp-ecoop/website/templates
by hhubner＠common-lisp.net 05 Feb '08

05 Feb '08

Author: hhubner Date: Tue Feb 5 16:04:47 2008 New Revision: 2443 Modified: trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl Log: another test checkin Modified: trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl (original) +++ trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl Tue Feb 5 16:04:47 2008 @@ -1,6 +1,6 @@ <?xml version="1.0" encoding="iso-8859-1" ?> <xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform" version="1.0" - xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net"> + xmlns:lisp-ecoop="http://elw.bknr.net/"> <xsl:param name="mode">xml</xsl:param> @@ -21,7 +21,7 @@ <body> <div id="banner"> <div id="title">4th European Lisp Workshop</div> - <div id="subtitle">Co-located with <a href="http://2007.ecoop.org/" target="_new">ECOOP 2007</a> July 30 - Berlin - Germany</div> + <div id="subtitle">Co-located with <a href="http://2008.ecoop.org/" target="_new">ECOOP 2008</a> July 30 - Berlin - Germany</div> <div id="logo"> <a href="http://bknr.net/" target="_new"> <img width="57" height="20" alt="BKNR Logo" src="/image/bknr-logo/thumbnail,,57,20" border="0" />

1 0