26 Nov '07
Author: hhubner
Date: 2007-11-26 06:24:22 -0500 (Mon, 26 Nov 2007)
New Revision: 2287
Modified:
branches/trunk-reorg/projects/scrabble/src/
Log:
ignore TAGS file
Property changes on: branches/trunk-reorg/projects/scrabble/src
___________________________________________________________________
Name: svn:ignore
+ TAGS
1
0
[bknr-cvs] r2286 - in branches/trunk-reorg/projects/scrabble: src website
by bknr＠bknr.net 26 Nov '07
by bknr＠bknr.net 26 Nov '07
26 Nov '07
Author: hhubner
Date: 2007-11-26 06:19:32 -0500 (Mon, 26 Nov 2007)
New Revision: 2286
Added:
branches/trunk-reorg/projects/scrabble/src/portable-queue.lisp
branches/trunk-reorg/projects/scrabble/src/publish-subscribe.lisp
branches/trunk-reorg/projects/scrabble/src/queue.lisp
Modified:
branches/trunk-reorg/projects/scrabble/src/game.lisp
branches/trunk-reorg/projects/scrabble/src/package.lisp
branches/trunk-reorg/projects/scrabble/src/scrabble.asd
branches/trunk-reorg/projects/scrabble/src/web.lisp
branches/trunk-reorg/projects/scrabble/website/scrabble.js
Log:
Add publish/subscribe mechanism.
Add queue implementation so that threads can signal each other with
some data. The queue implementation for OpenMCL uses CCL primitives
with timeout, the portable version uses the HUNCHENTOOT-MP package
and polling.
Modified: branches/trunk-reorg/projects/scrabble/src/game.lisp
===================================================================
--- branches/trunk-reorg/projects/scrabble/src/game.lisp 2007-11-25 05:37:30 UTC (rev 2285)
+++ branches/trunk-reorg/projects/scrabble/src/game.lisp 2007-11-26 11:19:32 UTC (rev 2286)
@@ -50,10 +50,20 @@
(vector-push-extend tile (tiles-of tile-bag)))
(shake-tile-bag tile-bag))
-(defclass player (user)
- ((games :initform nil :accessor games-of))
+(defclass player (user subscriber)
+ ((games :initform nil
+ :accessor games-of)
+ (event-queue :initform (make-instance 'queue)
+ :reader event-queue-of
+ :transient t)
+ (publish-subscribe:subscriptions :transient t))
(:metaclass persistent-class))
+(defmethod wait-for-event ((player player) timeout)
+ "Return next event for PLAYER or nil if TIMEOUT seconds have elapsed
+without any new events occuring on the queue."
+ (queue-pop (event-queue-of player) timeout))
+
(defclass participant (store-object)
((player :initarg :player :reader player-of)
(tray :initarg :tray :accessor tray-of)
@@ -74,7 +84,12 @@
(defclass move (store-object)
((participant :initarg :participant
:reader participant-of)
- (placed-tiles :initarg :placed-tiles
+ (time :initarg :time
+ :reader time-of))
+ (:metaclass persistent-class))
+
+(defclass letter-placement (move)
+ ((placed-tiles :initarg :placed-tiles
:reader placed-tiles-of)
(new-tiles-drawn :initarg :new-tiles-drawn
:reader new-tiles-drawn-of
@@ -93,7 +108,7 @@
(score-of move)
(words-formed-of move))))
-(defclass game (store-object)
+(defclass game (store-object publication)
((language :initarg :language
:reader language-of)
(board :initarg :board
@@ -105,7 +120,8 @@
:documentation "List of participants in this game")
(moves :initform nil
:accessor moves-of
- :documentation "List of moves that have been made in this game"))
+ :documentation "List of moves that have been made in this game")
+ (publish-subscribe:subscriptions :transient t))
(:metaclass persistent-class))
(deftransaction make-game (language players)
@@ -186,7 +202,17 @@
(append drawn (tray-of participant)))
drawn))
-(deftransaction make-move% (game participant placed-tiles)
+(defmethod signal-subscriber ((player player) (game game) move)
+ (queue-push (list :type "move" :game-id (store-object-id game) :move move)
+ (event-queue-of player)))
+
+(defun make-move (participant class &rest initargs)
+ (apply #'make-object class
+ :participant participant
+ :time (get-universal-time)
+ initargs))
+
+(deftransaction make-letter-placement% (game participant placed-tiles)
(dolist (placed-tile placed-tiles)
(when (used-for placed-tile)
(setf (used-for (tile-of placed-tile)) (used-for placed-tile))))
@@ -201,31 +227,29 @@
(when (eql 7 (length tiles-used))
(incf score 50))
(incf (score-of participant) score)
- (let ((move (make-object 'move
- :participant participant
- :placed-tiles placed-tiles
- :new-tiles-drawn tiles-drawn
- :words-formed words-formed
- :score score)))
+ (let ((move (make-move participant 'letter-placement
+ :placed-tiles placed-tiles
+ :new-tiles-drawn tiles-drawn
+ :words-formed words-formed
+ :score score)))
(push move (moves-of game))
(rotate-participants game)
+ (publish game move)
move))))
-(defun make-move (game participant placed-tiles)
+(defun make-letter-placement (game participant placed-tiles)
(ensure-participants-turn game participant)
(ensure-participant-has-tiles participant placed-tiles)
(check-move-legality (board-of game) placed-tiles)
- (make-move% game participant (mapcar (lambda (placement)
- (list (x-of placement)
- (y-of placement)
- (tile-of placement)
- (used-for placement)))
- placed-tiles)))
+ (make-letter-placement% game participant (mapcar (lambda (placement)
+ (list (x-of placement)
+ (y-of placement)
+ (tile-of placement)
+ (used-for placement)))
+ placed-tiles)))
-(defclass move-withdrawal (store-object)
- ((participant :initarg :participant
- :reader participant-of)
- (reason :initarg :reason
+(defclass move-withdrawal (move)
+ ((reason :initarg :reason
:reader reason-of))
(:metaclass persistent-class))
@@ -252,10 +276,8 @@
(error "last move was not a letter placement, can't be withdrawn"))
(withdraw-last-move% game reason move)))
-(defclass tile-swap (store-object)
- ((participant :initarg :participant
- :reader participant-of)
- (count :initarg :count
+(defclass tile-swap (move)
+ ((count :initarg :count
:reader count-of))
(:metaclass persistent-class))
Modified: branches/trunk-reorg/projects/scrabble/src/package.lisp
===================================================================
--- branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-11-25 05:37:30 UTC (rev 2285)
+++ branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-11-26 11:19:32 UTC (rev 2286)
@@ -1,10 +1,38 @@
+#+openmcl
+(defpackage :mp-utils
+ (:use :cl :ccl)
+ (:export "QUEUE"
+ "QUEUE-PUSH"
+ "QUEUE-POP"))
+
+#-openmcl
+(defpackage :mp-utils
+ (:use :cl :hunchentoot-mp)
+ (:export "QUEUE"
+ "QUEUE-PUSH"
+ "QUEUE-POP"))
+
+(defpackage :publish-subscribe
+ (:use :cl)
+ (:export "PUBLICATION"
+ "SUBSCRIBER"
+ "SUBSCRIBE-TO"
+ "SUBSCRIPTIONS"
+ "CANCEL-SUBSCRIPTION"
+ "CANCEL-SUBSCRIPTIONS"
+ "PUBLISH"
+ "SIGNAL-SUBSCRIBER"))
+
(defpackage :scrabble
(:use :cl
:alexandria
:anaphora
+ :publish-subscribe
+ :mp-utils
:bknr.datastore
:bknr.user)
+ (:shadowing-import-from :bknr.user "SUBSCRIPTIONS")
(:export "*BOARD-SCORING*"
"*TILE-SETS*"
@@ -25,6 +53,7 @@
"PLAYER"
"GAMES-OF"
+ "WAIT-FOR-EVENT"
"PARTICIPANT"
"PLAYER-OF"
@@ -35,17 +64,18 @@
"Y-OF"
"TILE-OF"
- "MAKE-MOVE"
-
- "MOVE"
+ "MAKE-LETTER-PLACEMENT"
+ "LETTER-PLACEMENT"
"SCORE-OF"
"PARTICIPANT-OF"
"WORDS-FORMED-OF"
"PLACED-TILES-OF"
- "MOVE-WITHDRAWAL"
+ "MAKE-MOVE-WITHDRAWAL"
+ "MOVE-WITHDRAWAL"
"REASON-OF"
+ "MAKE-TILE-SWAP"
"TILE-SWAP"
"COUNT-OF"
@@ -70,11 +100,13 @@
:hunchentoot
:bknr.datastore
:bknr.user
+ :publish-subscribe
:cl-who
:cl-interpol
:cl-ppcre
:json
- :scrabble)
+ :scrabble
+ :mp-utils)
+ (:shadowing-import-from :bknr.user "SUBSCRIPTIONS")
(:shadowing-import-from :cl-interpol "QUOTE-META-CHARS")
- (:export "START-WEBSERVER"))
-
\ No newline at end of file
+ (:export "START-WEBSERVER"))
\ No newline at end of file
Added: branches/trunk-reorg/projects/scrabble/src/portable-queue.lisp
===================================================================
--- branches/trunk-reorg/projects/scrabble/src/portable-queue.lisp 2007-11-25 05:37:30 UTC (rev 2285)
+++ branches/trunk-reorg/projects/scrabble/src/portable-queue.lisp 2007-11-26 11:19:32 UTC (rev 2286)
@@ -0,0 +1,35 @@
+(in-package :mp-utils)
+
+(defclass queue ()
+ ((count :initform 0 :accessor count-of)
+ (lock :initform (make-lock "queue") :reader lock-of)
+ (head :initform nil :accessor head-of)
+ (tail :initform nil :accessor tail-of)))
+
+(defmethod print-object ((queue queue) stream)
+ (print-unreadable-object (queue stream :type t :identity t)
+ (format stream "~A" (head-of queue))))
+
+(defmethod queue-push (data (queue queue))
+ (with-lock ((lock-of queue))
+ (let ((new-cell (cons data nil)))
+ (when (tail-of queue)
+ (setf (cdr (tail-of queue)) new-cell))
+ (setf (tail-of queue) new-cell)
+ (unless (head-of queue)
+ (setf (head-of queue) new-cell)))
+ (incf (count-of queue)))
+ queue)
+
+(defmethod queue-pop ((queue queue) timeout)
+ (loop while (plusp timeout)
+ do (with-lock ((lock-of queue))
+ (when (plusp (count-of queue))
+ (decf (count-of queue))
+ (let ((retval (pop (head-of queue))))
+ (unless (head-of queue)
+ (setf (tail-of queue) nil))
+ (return-from queue-pop (values retval t)))))
+ do (decf timeout)
+ do (sleep 1))
+ (values nil nil))
\ No newline at end of file
Added: branches/trunk-reorg/projects/scrabble/src/publish-subscribe.lisp
===================================================================
--- branches/trunk-reorg/projects/scrabble/src/publish-subscribe.lisp 2007-11-25 05:37:30 UTC (rev 2285)
+++ branches/trunk-reorg/projects/scrabble/src/publish-subscribe.lisp 2007-11-26 11:19:32 UTC (rev 2286)
@@ -0,0 +1,42 @@
+
+(in-package :publish-subscribe)
+
+(defclass publication ()
+ ((subscriptions :initform nil :accessor subscriptions-of)))
+
+(defclass subscription ()
+ ((subscriber :initarg :subscriber :reader subscriber-of)
+ (publication :initarg :publication :reader publication-of)))
+
+(defclass subscriber ()
+ ((subscriptions :initform nil :accessor subscriptions-of)))
+
+(defmethod subscribe-to ((subscriber subscriber)
+ (publication publication))
+ (make-instance 'subscription
+ :subscriber subscriber
+ :publication publication))
+
+(defmethod initialize-instance :after ((subscription subscription) &key)
+ (pushnew subscription (subscriptions-of (publication-of subscription)))
+ (pushnew subscription (subscriptions-of (subscriber-of subscription))))
+
+(defmethod cancel-subscription ((subscription subscription))
+ (with-slots (publication subscriber) subscription
+ (setf (subscriptions-of publication)
+ (remove subscription (subscriptions-of publication)))
+ (setf (subscriptions-of subscriber)
+ (remove subscription (subscriptions-of subscriber)))))
+
+(defmethod cancel-subscriptions (holder)
+ (mapcar #'cancel-subscription (subscriptions-of holder)))
+
+(defgeneric signal-subscriber (subscriber publication payload)
+ (:documentation "Notify SUBSCRIBER that PULICATION has been
+published with the given PAYLOAD."))
+
+(defmethod publish ((publication publication) payload)
+ (dolist (subscription (subscriptions-of publication))
+ (signal-subscriber (subscriber-of subscription)
+ (publication-of subscription)
+ payload)))
Added: branches/trunk-reorg/projects/scrabble/src/queue.lisp
===================================================================
--- branches/trunk-reorg/projects/scrabble/src/queue.lisp 2007-11-25 05:37:30 UTC (rev 2285)
+++ branches/trunk-reorg/projects/scrabble/src/queue.lisp 2007-11-26 11:19:32 UTC (rev 2286)
@@ -0,0 +1,31 @@
+(in-package :mp-utils)
+
+(defclass queue ()
+ ((semaphore :initform (make-semaphore) :reader semaphore-of)
+ (lock :initform (make-lock) :reader lock-of)
+ (head :initform nil :accessor head-of)
+ (tail :initform nil :accessor tail-of)))
+
+(defmethod print-object ((queue queue) stream)
+ (print-unreadable-object (queue stream :type t :identity t)
+ (format stream "~A" (head-of queue))))
+
+(defmethod queue-push (data (queue queue))
+ (with-lock-grabbed ((lock-of queue))
+ (let ((new-cell (cons data nil)))
+ (when (tail-of queue)
+ (setf (cdr (tail-of queue)) new-cell))
+ (setf (tail-of queue) new-cell)
+ (unless (head-of queue)
+ (setf (head-of queue) new-cell)))
+ (signal-semaphore (semaphore-of queue)))
+ queue)
+
+(defmethod queue-pop ((queue queue) timeout)
+ (if (timed-wait-on-semaphore (semaphore-of queue) timeout)
+ (with-lock-grabbed ((lock-of queue))
+ (let ((retval (pop (head-of queue))))
+ (unless (head-of queue)
+ (setf (tail-of queue) nil))
+ (values retval t)))
+ (values nil nil)))
\ No newline at end of file
Modified: branches/trunk-reorg/projects/scrabble/src/scrabble.asd
===================================================================
--- branches/trunk-reorg/projects/scrabble/src/scrabble.asd 2007-11-25 05:37:30 UTC (rev 2285)
+++ branches/trunk-reorg/projects/scrabble/src/scrabble.asd 2007-11-26 11:19:32 UTC (rev 2286)
@@ -23,6 +23,11 @@
:cl-json)
:serial t
:components ((:file "package")
+ (:file "publish-subscribe")
+ #+openmcl
+ (:file "queue")
+ #-openmcl
+ (:file "portable-queue")
(:file "game-constants")
(:file "rules")
(:file "game")
Modified: branches/trunk-reorg/projects/scrabble/src/web.lisp
===================================================================
--- branches/trunk-reorg/projects/scrabble/src/web.lisp 2007-11-25 05:37:30 UTC (rev 2285)
+++ branches/trunk-reorg/projects/scrabble/src/web.lisp 2007-11-26 11:19:32 UTC (rev 2286)
@@ -5,14 +5,16 @@
(defparameter *ignore-slots* '(bknr.datastore::id bknr.indices::destroyed-p))
(defun encode-json-plist (plist stream)
- (princ #\{ stream)
- (loop for (key value &rest rest) on plist by #'cddr
- do (encode-json key stream)
- do (princ #\: stream)
- do (encode-json value stream)
- when rest
- do (princ #\, stream))
- (princ #\} stream))
+ (let (printed)
+ (princ #\{ stream)
+ (loop for (key value) on plist by #'cddr
+ when printed
+ do (princ #\, stream)
+ do (setf printed t)
+ do (encode-json key stream)
+ do (princ #\: stream)
+ do (encode-json value stream))
+ (princ #\} stream)))
(defmethod encode-json ((object store-object) stream)
(let (printed)
@@ -28,6 +30,11 @@
(encode-json (slot-value object (closer-mop:slot-definition-name slotdef)) stream)))
(princ #\} stream)))
+(defmethod encode-json ((game game) stream)
+ (let ((*ignore-slots* (append *ignore-slots*
+ '(publish-subscribe::subscriptions))))
+ (call-next-method)))
+
(defmethod encode-json ((tile-bag tile-bag) stream)
(encode-json-plist (list :remaining-tiles (remaining-tile-count tile-bag)) stream))
@@ -43,7 +50,7 @@
(list :used-for it)))
stream))
-(defmethod encode-json ((move move) stream)
+(defmethod encode-json ((move letter-placement) stream)
(encode-json-plist (list :type "move"
:participant-login (user-login (player-of (participant-of move)))
:score (score-of move)
@@ -83,23 +90,23 @@
(defmethod encode-json ((participant participant) stream)
(start-session)
- (format t "user: ~A~%" (session-value :user))
(encode-json-plist (append (list :login (user-login (player-of participant))
:name (user-full-name (player-of participant))
:remaining-tiles)
- (list (if (equal (user-login (player-of participant))
- (session-value :user))
+ (list (if (eq (player-of participant)
+ (session-value :user))
(tray-of participant)
(length (tray-of participant)))))
stream))
-(define-easy-handler (login :uri "/login" :default-request-type :get)
+(define-easy-handler (login :uri "/login")
(login password)
(format t "warning: password not checked~*~%" password)
- (when (and login
- (find-user login))
+ (no-cache)
+ (awhen (and login
+ (find-user login))
(start-session)
- (setf (session-value :user) login)
+ (setf (session-value :user) it)
(redirect "/scrabble.html"))
(with-html-output-to-string (*standard-output* nil)
(:html
@@ -123,7 +130,6 @@
list-of-moves)
(labels
((use-letter (letter is-blank)
- (format t "use-letter ~A ~A~%" letter is-blank)
(awhen (find (if is-blank nil letter) tray :key #'letter-of)
(setf tray (remove it tray))
(return-from use-letter it))
@@ -151,25 +157,37 @@
(defmethod find-game ((game-id string))
(find-game (parse-integer game-id)))
-(define-easy-handler (make-move-handler :uri "/make-move" :default-request-type :post)
+(define-easy-handler (place-tiles-handler :uri "/place-tiles")
(move game)
(start-session)
+ (no-cache)
;; MOVE contains the move to make, GAME is the object ID of the game.
(with-output-to-string (s)
(handler-case
(progn
(let* ((game (find-game game))
- (participant (find (find-user (session-value :user)) (participants-of game) :key #'player-of)))
+ (participant (find (session-value :user) (participants-of game) :key #'player-of)))
(encode-json-plist
- (list :move (scrabble:make-move game
- participant
- (parse-move participant move))
+ (list :move (make-letter-placement game
+ participant
+ (parse-move participant move))
:tray (tray-of participant)) s)))
(error (e)
(encode-json-plist (list :error (princ-to-string e)) s)))))
+(defparameter *no-event-timeout* 60)
+
+(define-easy-handler (wait-event-handler :uri "/wait-event") ()
+ (start-session)
+ (no-cache)
+ (unless (session-value :user)
+ (redirect "/login"))
+ (with-output-to-string (s)
+ (encode-json-plist (wait-for-event (session-value :user) *no-event-timeout*) s)))
+
(define-easy-handler (games :uri "/games") ()
(start-session)
+ (no-cache)
(with-html-output-to-string (*standard-output* nil)
(:html
(:head
@@ -177,7 +195,7 @@
(:body
(:ul
(dolist (game (remove-if-not (lambda (game)
- (member (find-user (session-value :user)) (participants-of game)
+ (member (session-value :user) (participants-of game)
:key #'player-of))
(class-instances 'game)))
(htm
@@ -185,13 +203,16 @@
(defun game-handler ()
(start-session)
+ (no-cache)
(register-groups-bind (object-id-string) (#?r".*/(\d+)$" (request-uri))
- (let ((object (and object-id-string ; avoid sbcl warning
+ (let ((game (and object-id-string ; avoid sbcl warning
(find-store-object (parse-integer object-id-string)))))
- (when (typep object 'game)
+ (when (typep game 'game)
+ (awhen (session-value :user)
+ (subscribe-to it game))
(return-from game-handler
(with-output-to-string (s)
- (encode-json object s))))))
+ (encode-json game s))))))
(with-html-output-to-string (*standard-output* nil)
(:html
(:head
@@ -199,10 +220,11 @@
(:body
(:div "Invalid game ID")))))
-(define-easy-handler (move :uri "/move" :default-request-type :get)
+(define-easy-handler (move :uri "/move")
((game-id :parameter-type 'integer)
(move :parameter-type 'json:decode-json-from-string))
(start-session)
+ (no-cache)
(assert game-id)
(let ((game (find-store-object game-id)))
(assert game)
Modified: branches/trunk-reorg/projects/scrabble/website/scrabble.js
===================================================================
--- branches/trunk-reorg/projects/scrabble/website/scrabble.js 2007-11-25 05:37:30 UTC (rev 2285)
+++ branches/trunk-reorg/projects/scrabble/website/scrabble.js 2007-11-26 11:19:32 UTC (rev 2286)
@@ -111,13 +111,6 @@
appendChildNodes(container, board[x]);
}
- theirTrays = DIV();
- theirTrays.style.position = 'absolute';
- theirTrays.style.width = 7 * 44 + 'px';
- theirTrays.style.height = '70px';
- setElementPosition(theirTrays, { x: border + 16 * 40, y: border + 40 });
- appendChildNodes(container, theirTrays);
-
var shuffleButton = DIV(null, "shuffle");
shuffleButton.style.color = 'white';
shuffleButton.style.position = 'absolute';
@@ -193,13 +186,15 @@
}
};
- this.advance = function() {
+ this.advance = function(isHoriz) {
var horizontal = 1;
var vertical = 2;
var direction = this.direction;
if (direction == 0) {
// Direction not determined
- if (((this.y < 14) && letterAt(this.x, this.y + 1))
+ if (isHoriz != undefined) {
+ direction = isHoriz ? horizontal : vertical;
+ } else if (((this.y < 14) && letterAt(this.x, this.y + 1))
|| ((this.y > 1)
&& letterAt(this.x, this.y - 1)
&& !letterAt(this.x, this.y - 2))
@@ -257,7 +252,7 @@
function submitMove()
{
var queryString = MochiKit.Base.queryString({ move: move.toString(), game: gameID });
- var res = MochiKit.Async.doXHR("/make-move",
+ var res = MochiKit.Async.doXHR("/place-tiles",
{ method: 'POST',
sendContent: queryString,
headers: { "Content-Type": "application/x-www-form-urlencoded" } });
@@ -311,7 +306,11 @@
if (tilePosition == -1) {
alert("You don't have that letter!");
} else {
- cursor.advance();
+ var isHoriz;
+ if (move.length > 0) {
+ isHoriz = (move[0][0] != x);
+ }
+ cursor.advance(isHoriz);
if (!letterAt(x, y)) {
var tile = tray[tilePosition];
tray.splice(tilePosition, 1);
@@ -392,8 +391,7 @@
element.style.height = '34px';
element.style.zIndex = '10';
element.onclick = trayClick;
- // setElementPosition(element, { x: border + 194 + i * 40, y: border + 665 });
- YAHOO.util.Dom.setXY(element, [ border + 194 + i * 40, border + 665 ]);
+ setElementPosition(element, { x: border + 194 + i * 40, y: border + 665 });
tray[i] = element;
}
appendChildNodes($('playfield'), tray);
@@ -416,11 +414,28 @@
tray = newTray;
}
-function addTheirTray (participant) {
- appendChildNodes(theirTrays, DIV(null,
- DIV(null, participant.name),
- DIV(null, map(function () { return IMG({ src: 'images/null.png' }) },
- new Array(participant.remainingTiles)))));
+var otherPlayerIndex = 0;
+
+function makeTheirTray (name, tileCount) {
+ var tray = [];
+ for (var i = 0; i < tileCount; i++) {
+ var element = IMG({src: 'images/null.png'});
+ element.style.position = 'absolute';
+ element.style.width = '34px';
+ element.style.height = '34px';
+ element.style.zIndex = '10';
+ setElementPosition(element, { x: border + 680 + i * 40, y: border + 80 * otherPlayerIndex });
+ tray[i] = element;
+ }
+ appendChildNodes($('playfield'), tray);
+
+ var nameTag = DIV(null, name);
+ nameTag.style.position = 'absolute';
+ nameTag.style.width = '200px';
+ nameTag.style.textAlign = 'left';
+ setElementPosition(nameTag, { x: border + 680, y: border + 80 * otherPlayerIndex + 50 });
+ appendChildNodes($('playfield'), nameTag);
+ otherPlayerIndex++;
}
function drawGameState (gameState) {
@@ -433,7 +448,7 @@
for (var i = 0; i < gameState.participants.length; i++) {
var participant = gameState.participants[i];
if (typeof participant.remainingTiles == 'number') {
- addTheirTray(participant);
+ makeTheirTray(participant.name, participant.remainingTiles);
} else {
makeMyTray(map(function (entry) { return entry.letter }, participant.remainingTiles));
}
1
0
[bknr-cvs] r2285 - in branches/trunk-reorg/projects/scrabble: src website website/images/de website/images/en
by bknr＠bknr.net 25 Nov '07
by bknr＠bknr.net 25 Nov '07
25 Nov '07
Author: hhubner
Date: 2007-11-25 00:37:30 -0500 (Sun, 25 Nov 2007)
New Revision: 2285
Added:
branches/trunk-reorg/projects/scrabble/website/images/de/A-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/B-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/C-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/D-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/E-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/F-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/G-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/H-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/I-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/J-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/K-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/L-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/LATIN_CAPITAL_LETTER_A_WITH_DIAERESIS-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/LATIN_CAPITAL_LETTER_O_WITH_DIAERESIS-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/LATIN_CAPITAL_LETTER_U_WITH_DIAERESIS-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/M-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/N-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/O-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/P-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/Q-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/R-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/S-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/T-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/U-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/V-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/W-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/X-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/Y-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/Z-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/null-blank.png
branches/trunk-reorg/projects/scrabble/website/images/de/null.png
branches/trunk-reorg/projects/scrabble/website/images/de/start-field.png
branches/trunk-reorg/projects/scrabble/website/images/en/null.png
Removed:
branches/trunk-reorg/projects/scrabble/website/images/de/NIL.png
branches/trunk-reorg/projects/scrabble/website/images/en/NIL.png
Modified:
branches/trunk-reorg/projects/scrabble/src/game.lisp
branches/trunk-reorg/projects/scrabble/src/make-letters.lisp
branches/trunk-reorg/projects/scrabble/src/package.lisp
branches/trunk-reorg/projects/scrabble/src/rules.lisp
branches/trunk-reorg/projects/scrabble/src/web.lisp
branches/trunk-reorg/projects/scrabble/website/images/de/charmap.xml
branches/trunk-reorg/projects/scrabble/website/images/de/double-letter.png
branches/trunk-reorg/projects/scrabble/website/images/de/double-word.png
branches/trunk-reorg/projects/scrabble/website/images/de/triple-letter.png
branches/trunk-reorg/projects/scrabble/website/images/de/triple-word.png
branches/trunk-reorg/projects/scrabble/website/scrabble.css
branches/trunk-reorg/projects/scrabble/website/scrabble.html
branches/trunk-reorg/projects/scrabble/website/scrabble.js
Log:
Checkpoint: Various gameplay fixes, add start-field with star, add second
set of letter tiles with red lettering to signify placed blank tiles. Fix
json encoding for IE.
Modified: branches/trunk-reorg/projects/scrabble/src/game.lisp
===================================================================
--- branches/trunk-reorg/projects/scrabble/src/game.lisp 2007-11-17 10:28:57 UTC (rev 2284)
+++ branches/trunk-reorg/projects/scrabble/src/game.lisp 2007-11-25 05:37:30 UTC (rev 2285)
@@ -62,10 +62,11 @@
(defmethod print-object ((participant participant) stream)
(print-unreadable-object (participant stream :type t)
- (format stream "~A score: ~A, ~A tile~:P"
+ (format stream "~A score: ~A, ~A tile~:P: ~{~A~^, ~}"
(user-login (player-of participant))
(score-of participant)
- (length (tray-of participant)))))
+ (length (tray-of participant))
+ (mapcar #'letter-of (tray-of participant)))))
(defmethod tray-size ((participant participant))
(length (tray-of participant)))
@@ -133,7 +134,7 @@
(eq participant (next-participant-of game)))
(defun ensure-participants-turn (game participant)
- (unless (participants-turn-p game participant)
+ (unless (participants-turn-p game participant)
(error "It's not ~A's turn." (user-login (player-of participant)))))
(defun rotate-participants (game)
@@ -150,6 +151,12 @@
(defmethod letter-equal ((letter1 character) (letter2 (eql nil)))
nil)
+(defmethod letter-equal ((letter1 (eql nil)) (letter2 character))
+ nil)
+
+(defmethod letter-equal ((letter1 (eql nil)) (letter2 (eql nil)))
+ t)
+
(defmethod letter-equal ((tile1 tile) (tile2 tile))
(letter-equal (letter-of tile1) (letter-of tile2)))
@@ -157,9 +164,9 @@
(let ((tray-letters (mapcar #'letter-of (tray-of participant)))
(placed-letters (mapcar (compose #'letter-of #'tile-of) placed-tiles)))
(dolist (letter placed-letters)
- (let ((has-letter (find letter tray-letters :test #'letter-equal)))
+ (let ((has-letter (position letter tray-letters :test #'letter-equal)))
(unless (or has-letter (find nil tray-letters))
- (error "participant ~A does not have tile ~A" participant letter))
+ (error "participant ~A does not have tile ~A" participant letter))
(setf tray-letters
(if has-letter
(remove letter tray-letters :test #'letter-equal :count 1)
@@ -180,9 +187,12 @@
drawn))
(deftransaction make-move% (game participant placed-tiles)
+ (dolist (placed-tile placed-tiles)
+ (when (used-for placed-tile)
+ (setf (used-for (tile-of placed-tile)) (used-for placed-tile))))
(let ((words-formed (mapcar (lambda (word-result)
(cons (word-text word-result) (word-score word-result)))
- (words-formed (board-of game) placed-tiles))))
+ (words-formed (board-of game) placed-tiles))))
(dolist (placed-tile placed-tiles)
(put-letter (board-of game) (tile-of placed-tile) (x-of placed-tile) (y-of placed-tile)))
(let ((tiles-used (remove-letters-from-participant-tray participant (mapcar #'tile-of placed-tiles)))
@@ -206,7 +216,10 @@
(ensure-participant-has-tiles participant placed-tiles)
(check-move-legality (board-of game) placed-tiles)
(make-move% game participant (mapcar (lambda (placement)
- (list (x-of placement) (y-of placement) (tile-of placement)))
+ (list (x-of placement)
+ (y-of placement)
+ (tile-of placement)
+ (used-for placement)))
placed-tiles)))
(defclass move-withdrawal (store-object)
Modified: branches/trunk-reorg/projects/scrabble/src/make-letters.lisp
===================================================================
--- branches/trunk-reorg/projects/scrabble/src/make-letters.lisp 2007-11-17 10:28:57 UTC (rev 2284)
+++ branches/trunk-reorg/projects/scrabble/src/make-letters.lisp 2007-11-25 05:37:30 UTC (rev 2285)
@@ -39,23 +39,30 @@
(defparameter *tile-color* '(1.0 0.98 0.8))
-(defparameter *bold-font* #.(merge-pathnames #p"../fonts/DIN/DINMd___.ttf" *default-pathname-defaults*))
-(defparameter *regular-font* #.(merge-pathnames #p"../fonts/DIN/DINRg___.ttf" *default-pathname-defaults*))
+(defparameter *bold-font* #.(merge-pathnames #p"/home/hans/fonts/DIN/DINMd___.ttf" *default-pathname-defaults*))
+(defparameter *regular-font* #.(merge-pathnames #p"/home/hans/fonts/DIN/DINRg___.ttf" *default-pathname-defaults*))
-(defun make-letter-tile (char score)
+(defun make-letter-tile (char score blank-used)
(with-canvas (:width 34 :height 34)
(let* ((bold-font (get-font *bold-font*))
(regular-font (get-font *regular-font*))
(char-string (princ-to-string char))
- (pathname (make-pathname :name (if (and char (> (char-code char) 127))
- (char-name char)
- char-string)
+ (filename (format nil "~A~@[-blank~]"
+ (if char
+ (if (> (char-code char) 127)
+ (char-name char)
+ char-string)
+ "null")
+ blank-used))
+ (pathname (make-pathname :name filename
:type "png")))
(apply #'set-rgb-fill *tile-color*)
(rounded-rectangle 0 0 34 34 4 4)
(fill-path)
(when char
- (set-rgb-fill 0 0 0)
+ (if (and blank-used char)
+ (set-rgb-fill 0.9 0 0)
+ (set-rgb-fill 0 0 0))
(set-font bold-font 27)
(draw-centered-string 13 7 char-string)
(set-font regular-font 11)
@@ -77,11 +84,12 @@
:external-format :utf-8)
(cxml:with-xml-output (cxml:make-character-stream-sink letter-map-file)
(cxml:with-element "chars"
- (dolist (entry (gethash language *tile-sets*))
+ (dolist (entry (getf *tile-sets* language))
(destructuring-bind (letter score count) entry
(declare (ignore count))
(cxml:with-element "char"
- (cxml:attribute "filename" (namestring (make-letter-tile letter score)))
+ (cxml:attribute "filename" (namestring (make-letter-tile letter score nil)))
+ (cxml:attribute "blank-filename" (namestring (make-letter-tile letter score t)))
(cxml:text (princ-to-string letter)))))))))
(defun make-cursor ()
@@ -92,6 +100,21 @@
(stroke)
(save-png #P"cursor.png")))
+(defun draw-star (size border)
+ (with-graphics-state
+ (let ((half-size (/ size 2))
+ (angle 0)
+ (step (* 2 (/ (* pi 2) 5))))
+ (translate (+ border half-size) (+ border half-size))
+ (move-to 0 half-size)
+ (dotimes (i 5)
+ (setf angle (+ angle step))
+ (line-to (* (sin angle) half-size)
+ (* (cos angle) half-size)))
+ (close-subpath)
+ (set-rgb-fill 0 0 0)
+ (fill-path))))
+
(defun make-special-field (name color &key text star)
(with-canvas (:width 40 :height 40)
(let ((regular-font (get-font *regular-font*)))
@@ -108,7 +131,7 @@
(draw-centered-string 20 position line)
(decf position 6))))
(star
- ))
+ (draw-star 30 5)))
(save-png (make-pathname :name (string-downcase (symbol-name name)) :type "png")))))
(defun make-special-field-set (language)
@@ -117,7 +140,7 @@
(getf *special-field-colors* tile-name)
:text (getf (gethash language *special-field-texts*) tile-name)))
(make-special-field :standard (getf *special-field-colors* :standard) :star nil)
- (make-special-field :standard (getf *special-field-colors* :double-word) :star t))
+ (make-special-field :start-field (getf *special-field-colors* :double-word) :star t))
(defun make-tile-set (directory language)
(let ((*default-pathname-defaults*
@@ -128,3 +151,21 @@
(make-letter-tile-set language)
(make-special-field-set language)
(make-cursor)))
+
+
+
+(defun star-test (size border)
+ (with-canvas (:width size :height size)
+ (let ((star-size (/ (- size (* 2 border)) 2))
+ (angle 0)
+ (step (* 2 (/ (* pi 2) 5))))
+ (translate (+ border star-size) (+ border star-size))
+ (move-to 0 star-size)
+ (dotimes (i 5)
+ (setf angle (+ angle step))
+ (line-to (* (sin angle) star-size)
+ (* (cos angle) star-size)))
+ (close-subpath)
+ (set-rgb-fill 0 0 0)
+ (fill-path)
+ (save-png "/home/hans/bknr-svn/projects/scrabble/website/images/de/star.png"))))
Modified: branches/trunk-reorg/projects/scrabble/src/package.lisp
===================================================================
--- branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-11-17 10:28:57 UTC (rev 2284)
+++ branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-11-25 05:37:30 UTC (rev 2285)
@@ -12,7 +12,10 @@
"TILE"
"LETTER-OF"
+ "LETTER-NAME-OF"
"VALUE-OF"
+ "BLANK-TILE"
+ "USED-FOR"
"BOARD"
"AT-XY"
@@ -43,6 +46,9 @@
"MOVE-WITHDRAWAL"
"REASON-OF"
+ "TILE-SWAP"
+ "COUNT-OF"
+
"GAME"
"LANGUAGE-OF"
"PARTICIPANTS-OF"
Modified: branches/trunk-reorg/projects/scrabble/src/rules.lisp
===================================================================
--- branches/trunk-reorg/projects/scrabble/src/rules.lisp 2007-11-17 10:28:57 UTC (rev 2284)
+++ branches/trunk-reorg/projects/scrabble/src/rules.lisp 2007-11-25 05:37:30 UTC (rev 2285)
@@ -24,15 +24,20 @@
(defclass tile-placement ()
((x :reader x-of :initarg :x)
(y :reader y-of :initarg :y)
- (tile :reader tile-of :initarg :tile))
+ (tile :reader tile-of :initarg :tile)
+ (used-for :reader used-for :initarg :used-for))
(:documentation "Represents placement of a letter tile on the board"))
(defmethod print-object ((tile-placement tile-placement) stream)
(print-unreadable-object (tile-placement stream :type t)
- (format stream "~A ~A => ~A" (x-of tile-placement) (y-of tile-placement) (tile-of tile-placement))))
+ (format stream "~A ~A => ~A ~@[(~A)~]"
+ (x-of tile-placement)
+ (y-of tile-placement)
+ (tile-of tile-placement)
+ (used-for tile-placement))))
-(defun make-tile-placement (x y tile)
- (make-instance 'tile-placement :x x :y y :tile tile))
+(defun make-tile-placement (x y tile used-for)
+ (make-instance 'tile-placement :x x :y y :tile tile :used-for used-for))
(defun make-tile-placements (list-of-moves)
(mapcar (curry #'apply 'make-tile-placement) list-of-moves))
@@ -60,7 +65,7 @@
(terpri stream)
(dotimes (x 15)
(dotimes (y 15)
- (format stream "~C " (aif (at-xy board x y) (letter-of it) #\.)))
+ (format stream "~C " (aif (at-xy board x y) (used-for it) #\.)))
(terpri stream))))
(defmethod at-xy ((board board) x y)
@@ -77,14 +82,47 @@
(value :reader value-of :initarg :value))
(:metaclass persistent-class))
+(defmethod used-for ((tile tile))
+ (letter-of tile))
+
+(defclass blank-tile (tile)
+ ((used-for :accessor used-for :initform nil))
+ (:default-initargs :letter nil :value 0)
+ (:metaclass persistent-class))
+
+(defmethod letter-name-of ((character character))
+ (if (and (char-name character)
+ (< 127 (char-code character)))
+ (string-upcase (char-name character))
+ (make-string 1 :initial-element character)))
+
+(defmethod letter-name-of ((tile tile))
+ (letter-name-of (letter-of tile)))
+
+(defmethod letter-name-of ((tile blank-tile))
+ (awhen (used-for tile)
+ (letter-name-of it)))
+
(defmethod print-object ((tile tile) stream)
(print-unreadable-object (tile stream :type t :identity nil)
(with-slots (letter value) tile
- (format stream "~A (~A) ID:~A" (when letter (char-name letter)) value (store-object-id tile)))))
+ (format stream "~A (~A) ID:~A" (when letter (letter-name-of letter)) value (store-object-id tile)))))
-(defun make-tile (letter value)
+(defmethod print-object ((tile blank-tile) stream)
+ (print-unreadable-object (tile stream :type t :identity nil)
+ (with-slots (letter value) tile
+ (format stream "~@[used for ~A ~]ID:~A"
+ (when (used-for tile)
+ (letter-name-of (used-for tile)))
+ (store-object-id tile)))))
+
+(defmethod make-tile ((letter character) value)
(make-object 'tile :letter letter :value value))
+(defmethod make-tile ((letter (eql nil)) value)
+ (declare (ignore value))
+ (make-object 'blank-tile))
+
(defmethod placed-tile-adjacent ((board board) (tile-placement tile-placement))
"Check whether the given TILE-PLACEMENT on the board is adjacent to
another tile or if it is the start position."
@@ -125,7 +163,7 @@
(error 'not-in-a-row))
(when (some (curry #'at-placement board) placed-tiles)
- (error 'tile-placed-on-occupied-field))
+ (error 'placed-on-occupied-field))
(unless (equal placed-tiles
(remove-duplicates placed-tiles :test #'equal-position))
@@ -142,7 +180,7 @@
(unless (or (find '(7 7) placed-tiles :test #'position-equal)
(some (curry #'placed-tile-adjacent board) placed-tiles))
(error 'not-touching-other-tile))
-
+
t)
(defmethod x-of ((placement list))
@@ -154,6 +192,9 @@
(defmethod tile-of ((placement list))
(third placement))
+(defmethod used-for ((placement list))
+ (fourth placement))
+
(defun words-formed% (board placed-tiles verticalp)
"Scan for words that would be formed by placing PLACED-TILES on
BOARD. VERTICALP determines the scan order, if nil, the board is
@@ -164,11 +205,13 @@
(when (find x placed-tiles :key (if verticalp #'y-of #'x-of) :test #'=)
(let (word is-new-word)
(dotimes (y 15)
- (multiple-value-bind (placed-tile being-placed) (placed-or-being-placed board placed-tiles (if verticalp (list y x) (list x y)))
+ (multiple-value-bind (placed-tile being-placed)
+ (placed-or-being-placed board placed-tiles (if verticalp (list y x) (list x y)))
(when (and word (null placed-tile))
(when (and (cdr word) is-new-word)
(push (nreverse word) words))
- (setf word nil is-new-word nil))
+ (setf word nil
+ is-new-word nil))
(when placed-tile
(push (list placed-tile (and being-placed (field-type x y))) word)
(when being-placed
@@ -205,5 +248,4 @@
(defun word-text (word-result)
"Convert the letter in a word result returned by WORDS-FORMED to a
string."
- (coerce (mapcar (compose #'letter-of #'car) word-result) 'string))
-
+ (coerce (mapcar (compose #'used-for #'car) word-result) 'string))
Modified: branches/trunk-reorg/projects/scrabble/src/web.lisp
===================================================================
--- branches/trunk-reorg/projects/scrabble/src/web.lisp 2007-11-17 10:28:57 UTC (rev 2284)
+++ branches/trunk-reorg/projects/scrabble/src/web.lisp 2007-11-25 05:37:30 UTC (rev 2285)
@@ -6,27 +6,43 @@
(defun encode-json-plist (plist stream)
(princ #\{ stream)
- (loop for (key value) on plist by #'cddr
+ (loop for (key value &rest rest) on plist by #'cddr
do (encode-json key stream)
do (princ #\: stream)
do (encode-json value stream)
+ when rest
do (princ #\, stream))
(princ #\} stream))
(defmethod encode-json ((object store-object) stream)
- (princ #\{ stream)
- (dolist (slotdef (closer-mop:class-slots (class-of object)))
- (when (and (slot-boundp object (closer-mop:slot-definition-name slotdef))
- (not (find (closer-mop:slot-definition-name slotdef) *ignore-slots*)))
- (encode-json (closer-mop:slot-definition-name slotdef) stream)
- (princ #\: stream)
- (encode-json (slot-value object (closer-mop:slot-definition-name slotdef)) stream)
- (princ #\, stream)))
- (princ #\} stream))
+ (let (printed)
+ (princ #\{ stream)
+ (dolist (slotdef (closer-mop:class-slots (class-of object)))
+ (when (and (slot-boundp object (closer-mop:slot-definition-name slotdef))
+ (not (find (closer-mop:slot-definition-name slotdef) *ignore-slots*)))
+ (if printed
+ (princ #\, stream)
+ (setf printed t))
+ (encode-json (closer-mop:slot-definition-name slotdef) stream)
+ (princ #\: stream)
+ (encode-json (slot-value object (closer-mop:slot-definition-name slotdef)) stream)))
+ (princ #\} stream)))
(defmethod encode-json ((tile-bag tile-bag) stream)
(encode-json-plist (list :remaining-tiles (remaining-tile-count tile-bag)) stream))
+(defmethod encode-json ((tile tile) stream)
+ (encode-json-plist (list :letter (letter-name-of tile)
+ :value (value-of tile))
+ stream))
+
+(defmethod encode-json ((tile blank-tile) stream)
+ (encode-json-plist (append (list :letter nil
+ :value 0)
+ (awhen (used-for tile)
+ (list :used-for it)))
+ stream))
+
(defmethod encode-json ((move move) stream)
(encode-json-plist (list :type "move"
:participant-login (user-login (player-of (participant-of move)))
@@ -44,17 +60,30 @@
:reason (or (reason-of move) ""))
stream))
+(defmethod encode-json ((move tile-swap) stream)
+ (encode-json-plist (list :type "tile-swap"
+ :participant-login (user-login (player-of (participant-of move)))
+ :reason (count-of move))
+ stream))
+
(defmethod encode-json ((board board) stream)
- (princ #\[ stream)
- (dotimes (x 15)
- (dotimes (y 15)
- (awhen (at-xy board x y)
- (encode-json (list x y (letter-of it) (value-of it)) stream)
- (princ #\, stream))))
- (princ #\] stream))
+ (let (printed)
+ (princ #\[ stream)
+ (dotimes (x 15)
+ (dotimes (y 15)
+ (awhen (at-xy board x y)
+ (if printed
+ (princ #\, stream)
+ (setf printed t))
+ (encode-json (append (list x y (letter-name-of it))
+ (when (typep it 'scrabble::blank-tile)
+ (list 1)))
+ stream))))
+ (princ #\] stream)))
(defmethod encode-json ((participant participant) stream)
(start-session)
+ (format t "user: ~A~%" (session-value :user))
(encode-json-plist (append (list :login (user-login (player-of participant))
:name (user-full-name (player-of participant))
:remaining-tiles)
@@ -84,27 +113,31 @@
(:tr (:td) (:td (:input :type "SUBMIT")))))))))
(defun parse-move (participant string)
- "Given a string X1,Y1,LETTER1,X2,Y2,LETTER2..., return a list of
-moves ((X1 Y1 LETTER-TILE2) (X2 Y2 LETTER-TILE2) ...). LETTERx may
-either be a single-character letter which will be used directly or a
-character name (like LATIN_CAPITAL_LETTER_U_WITH_DIAERESIS) which will
-be converted into a character using NAME-CHAR."
+ "Given a string X1,Y1,LETTER1,FLAG1,X2,Y2,LETTER2,FLAG2..., return a
+list of moves ((X1 Y1 LETTER-TILE1 FLAG1) (X2 Y2 LETTER-TILE2 FLAG2)
+...). LETTERx may either be a single-character letter which will be
+used directly or a character name (like
+LATIN_CAPITAL_LETTER_U_WITH_DIAERESIS) which will be converted into a
+character using NAME-CHAR."
(let ((tray (tray-of participant))
list-of-moves)
(labels
- ((use-letter (letter)
- (awhen (or (find letter tray :key #'letter-of)
- (find nil tray :key #'letter-of))
+ ((use-letter (letter is-blank)
+ (format t "use-letter ~A ~A~%" letter is-blank)
+ (awhen (find (if is-blank nil letter) tray :key #'letter-of)
(setf tray (remove it tray))
(return-from use-letter it))
(error "tray of ~A does not contain letter ~A" participant letter))
- (recurse (x-string y-string letter &rest more)
- (push (list (parse-integer x-string)
- (parse-integer y-string)
- (use-letter (if (= 1 (length letter))
- (aref letter 0)
- (name-char letter))))
- list-of-moves)
+ (recurse (x-string y-string letter is-blank &rest more)
+ (let ((letter (if (= 1 (length letter))
+ (aref letter 0)
+ (name-char letter)))
+ (is-blank (string-equal "true" is-blank)))
+ (push (list (parse-integer x-string)
+ (parse-integer y-string)
+ (use-letter letter is-blank)
+ (when is-blank letter))
+ list-of-moves))
(when more
(apply #'recurse more))))
(apply #'recurse (split "," string)))
Added: branches/trunk-reorg/projects/scrabble/website/images/de/A-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/A-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/B-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/B-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/C-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/C-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/D-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/D-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/E-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/E-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/F-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/F-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/G-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/G-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/H-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/H-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/I-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/I-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/J-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/J-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/K-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/K-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/L-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/L-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/LATIN_CAPITAL_LETTER_A_WITH_DIAERESIS-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/LATIN_CAPITAL_LETTER_A_WITH_DIAERESIS-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/LATIN_CAPITAL_LETTER_O_WITH_DIAERESIS-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/LATIN_CAPITAL_LETTER_O_WITH_DIAERESIS-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/LATIN_CAPITAL_LETTER_U_WITH_DIAERESIS-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/LATIN_CAPITAL_LETTER_U_WITH_DIAERESIS-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/M-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/M-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/N-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/N-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Deleted: branches/trunk-reorg/projects/scrabble/website/images/de/NIL.png
===================================================================
(Binary files differ)
Added: branches/trunk-reorg/projects/scrabble/website/images/de/O-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/O-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/P-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/P-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/Q-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/Q-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/R-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/R-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/S-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/S-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/T-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/T-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/U-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/U-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/V-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/V-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/W-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/W-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/X-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/X-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/Y-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/Y-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/Z-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/Z-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Modified: branches/trunk-reorg/projects/scrabble/website/images/de/charmap.xml
===================================================================
--- branches/trunk-reorg/projects/scrabble/website/images/de/charmap.xml 2007-11-17 10:28:57 UTC (rev 2284)
+++ branches/trunk-reorg/projects/scrabble/website/images/de/charmap.xml 2007-11-25 05:37:30 UTC (rev 2285)
@@ -1,2 +1,2 @@
<?xml version="1.0" encoding="UTF-8"?>
-<chars><char filename="A.png">A</char><char filename="B.png">B</char><char filename="C.png">C</char><char filename="D.png">D</char><char filename="E.png">E</char><char filename="F.png">F</char><char filename="G.png">G</char><char filename="H.png">H</char><char filename="I.png">I</char><char filename="J.png">J</char><char filename="K.png">K</char><char filename="L.png">L</char><char filename="M.png">M</char><char filename="N.png">N</char><char filename="O.png">O</char><char filename="P.png">P</char><char filename="Q.png">Q</char><char filename="R.png">R</char><char filename="S.png">S</char><char filename="T.png">T</char><char filename="U.png">U</char><char filename="V.png">V</char><char filename="W.png">W</char><char filename="X.png">X</char><char filename="Y.png">Y</char><char filename="Z.png">Z</char><char filename="LATIN_CAPITAL_LETTER_A_WITH_DIAERESIS.png">Ä</char><char filename="LATIN_CAPITAL_LETTER_O_WITH_DIAERESIS.png">Ö</char><char filename="LATIN_CAPITAL_LETTER_U_WITH_DIAERESIS.png">Ü</char><char filename="NIL.png">NIL</char></chars>
\ No newline at end of file
+<chars><char filename="A.png" blank-filename="A-blank.png">A</char><char filename="B.png" blank-filename="B-blank.png">B</char><char filename="C.png" blank-filename="C-blank.png">C</char><char filename="D.png" blank-filename="D-blank.png">D</char><char filename="E.png" blank-filename="E-blank.png">E</char><char filename="F.png" blank-filename="F-blank.png">F</char><char filename="G.png" blank-filename="G-blank.png">G</char><char filename="H.png" blank-filename="H-blank.png">H</char><char filename="I.png" blank-filename="I-blank.png">I</char><char filename="J.png" blank-filename="J-blank.png">J</char><char filename="K.png" blank-filename="K-blank.png">K</char><char filename="L.png" blank-filename="L-blank.png">L</char><char filename="M.png" blank-filename="M-blank.png">M</char><char filename="N.png" blank-filename="N-blank.png">N</char><char filename="O.png" blank-filename="O-blank.png">O</char><char filename="P.png" blank-filename="P-blank.png">P</char><char filename="Q.png" blank-filename="Q-blank.png">Q</char><char filename="R.png" blank-filename="R-blank.png">R</char><char filename="S.png" blank-filename="S-blank.png">S</char><char filename="T.png" blank-filename="T-blank.png">T</char><char filename="U.png" blank-filename="U-blank.png">U</char><char filename="V.png" blank-filename="V-blank.png">V</char><char filename="W.png" blank-filename="W-blank.png">W</char><char filename="X.png" blank-filename="X-blank.png">X</char><char filename="Y.png" blank-filename="Y-blank.png">Y</char><char filename="Z.png" blank-filename="Z-blank.png">Z</char><char filename="LATIN_CAPITAL_LETTER_A_WITH_DIAERESIS.png" blank-filename="LATIN_CAPITAL_LETTER_A_WITH_DIAERESIS-blank.png">Ä</char><char filename="LATIN_CAPITAL_LETTER_O_WITH_DIAERESIS.png" blank-filename="LATIN_CAPITAL_LETTER_O_WITH_DIAERESIS-blank.png">Ö</char><char filename="LATIN_CAPITAL_LETTER_U_WITH_DIAERESIS.png" blank-filename="LATIN_CAPITAL_LETTER_U_WITH_DIAERESIS-blank.png">Ü</char><char filename="null.png" blank-filename="null-blank.png">NIL</char></chars>
\ No newline at end of file
Modified: branches/trunk-reorg/projects/scrabble/website/images/de/double-letter.png
===================================================================
(Binary files differ)
Modified: branches/trunk-reorg/projects/scrabble/website/images/de/double-word.png
===================================================================
(Binary files differ)
Added: branches/trunk-reorg/projects/scrabble/website/images/de/null-blank.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/null-blank.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Copied: branches/trunk-reorg/projects/scrabble/website/images/de/null.png (from rev 2277, branches/trunk-reorg/projects/scrabble/website/images/de/NIL.png)
Added: branches/trunk-reorg/projects/scrabble/website/images/de/start-field.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/start-field.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Modified: branches/trunk-reorg/projects/scrabble/website/images/de/triple-letter.png
===================================================================
(Binary files differ)
Modified: branches/trunk-reorg/projects/scrabble/website/images/de/triple-word.png
===================================================================
(Binary files differ)
Deleted: branches/trunk-reorg/projects/scrabble/website/images/en/NIL.png
===================================================================
(Binary files differ)
Copied: branches/trunk-reorg/projects/scrabble/website/images/en/null.png (from rev 2277, branches/trunk-reorg/projects/scrabble/website/images/en/NIL.png)
Modified: branches/trunk-reorg/projects/scrabble/website/scrabble.css
===================================================================
--- branches/trunk-reorg/projects/scrabble/website/scrabble.css 2007-11-17 10:28:57 UTC (rev 2284)
+++ branches/trunk-reorg/projects/scrabble/website/scrabble.css 2007-11-25 05:37:30 UTC (rev 2285)
@@ -1,2 +1,2 @@
body { background-color: #004B36; color: #ffffff; font-family: sans-serif }
-#playfield { position: absolute }
+#playfield { position: absolute; top: 0px; left: 0px }
Modified: branches/trunk-reorg/projects/scrabble/website/scrabble.html
===================================================================
--- branches/trunk-reorg/projects/scrabble/website/scrabble.html 2007-11-17 10:28:57 UTC (rev 2284)
+++ branches/trunk-reorg/projects/scrabble/website/scrabble.html 2007-11-25 05:37:30 UTC (rev 2285)
@@ -10,7 +10,7 @@
<script type="text/javascript" src="scrabble.js"> </script>
</head>
<body onload="init()">
- <div id='playfield'>
+ <div id="playfield">
</div>
<div style="position: absolute; right: 20px; top: 20px;"><a style="color: white;" href="/login?login=user1">user1</a></div>
<div style="position: absolute; right: 20px; top: 40px;"><a style="color: white;" href="/login?login=user2">user2</a></div>
Modified: branches/trunk-reorg/projects/scrabble/website/scrabble.js
===================================================================
--- branches/trunk-reorg/projects/scrabble/website/scrabble.js 2007-11-17 10:28:57 UTC (rev 2284)
+++ branches/trunk-reorg/projects/scrabble/website/scrabble.js 2007-11-25 05:37:30 UTC (rev 2285)
@@ -39,7 +39,7 @@
// return if the move is legal.
var positions = map(function (placement) { return [ placement[0], placement[1] ] }, placedTiles)
- .sort(function (a, b) { (a[0] > b[0]) || (a[1] > b[1])});
+ .sort(function (a, b) { return (a[0] - b[0]) || (a[1] - b[1])});
if (filter(partial(operator.ne, positions[0][0]), map(function (position) { return position[0] }, positions)).length
&& filter(partial(operator.ne, positions[0][1]), map(function (position) { return position[1] }, positions)).length) {
@@ -59,8 +59,8 @@
if (findValue(positions, [ 7, 7 ]) == -1) {
var found = false;
- for (var x = startOfPlacement[0]; !found && x <= endOfPlacement[0]; x++) {
- for (var y = startOfPlacement[1]; !found && y <= endOfPlacement[1]; y++) {
+ for (var x = startOfPlacement[0]; !found && (x <= endOfPlacement[0]); x++) {
+ for (var y = startOfPlacement[1]; !found && (y <= endOfPlacement[1]); y++) {
if (((x > 0) && letterAt(x - 1, y))
|| ((x < 14) && letterAt(x + 1, y))
|| ((y > 0) && letterAt(x, y - 1))
@@ -83,6 +83,7 @@
}
var theirTrays;
+var tray = [];
var gameID = 108;
var board;
@@ -99,7 +100,8 @@
element.style.position = 'absolute';
element.style.width = '40px';
element.style.height = '40px';
- element.style.backgroundImage = 'url(images/' + getFieldScore(x, y) + '.png)';
+ var imageName = (x == 7 && y == 7) ? "start-field" : getFieldScore(x, y);
+ element.style.backgroundImage = 'url(images/' + imageName + '.png)';
element.x = x;
element.y = y;
setElementPosition(element, { x: border + x * 44, y: border + y * 44 });
@@ -109,13 +111,6 @@
appendChildNodes(container, board[x]);
}
- myTrayContainer = DIV();
- myTrayContainer.style.position = 'absolute';
- myTrayContainer.style.width = 7 * 44 + 'px';
- myTrayContainer.style.height = '44px';
- setElementPosition(myTrayContainer, { x: border + 194, y: border + 665 });
- appendChildNodes(container, myTrayContainer);
-
theirTrays = DIV();
theirTrays.style.position = 'absolute';
theirTrays.style.width = 7 * 44 + 'px';
@@ -138,25 +133,34 @@
// appendChildNodes(container, clearButton);
}
-function setLetter(x, y, letter, justPlaced) {
- var image = IMG({ src: 'images/' + letter + '.png'});
+function setLetter(x, y, letter, isBlank) {
+ var image = IMG({ src: 'images/' + letter + (isBlank ? "-blank" : "") + '.png'});
image.style.position = 'absolute';
image.style.top = '3px';
image.style.left = '3px';
- replaceChildNodes(board[x][y], image);
- if (justPlaced) {
- var mask = IMG({ src: 'images/mask.png'});
- mask.style.position = 'absolute';
- mask.style.top = '3px';
- mask.style.left = '3px';
- appendChildNodes(board[x][y], mask);
- }
+ setElementPosition(image, { x: border + x * 44 + 3, y: border + y * 44 + 3 });
+ appendChildNodes($('playfield'), image);
board[x][y].letterNode = image;
board[x][y].letter = letter;
- board[x][y].justPlaced = justPlaced;
- YAHOO.util.Event.purgeElement(board[x][y], false, 'click');
}
+function placeLetter(x, y, tile) {
+ var mask = IMG({ src: 'images/mask.png'});
+ mask.style.position = 'absolute';
+ mask.style.top = '3px';
+ mask.style.left = '3px';
+ mask.style.zIndex = '20';
+ appendChildNodes(board[x][y], mask);
+ board[x][y].letterNode = tile;
+ board[x][y].letter = tile.letter;
+ board[x][y].justPlaced = true;
+ tile.anim = new YAHOO.util.Motion(tile, { points: { to: [ border + x * 44 + 3,
+ border + y * 44 + 3 ]}},
+ 0.15,
+ YAHOO.util.Easing.easeBoth);
+ tile.anim.animate();
+}
+
function letterAt(x, y) {
return board[x][y].letter && !board[x][y].justPlaced;
}
@@ -176,12 +180,14 @@
this.set = function(x, y) {
this.x = x;
this.y = y;
- replaceChildNodes(board[x][y], this.image);
+ appendChildNodes(board[x][y], this.image);
+ board[x][y].cursor = this.image;
};
this.clear = function() {
if (this.x != -1) {
- replaceChildNodes(board[this.x][this.y]);
+ removeElement(board[this.x][this.y].cursor);
+ board[this.x][this.y].cursor = undefined;
this.x = this.y = -1;
this.direction = 0;
}
@@ -211,18 +217,8 @@
this.direction = direction;
if (this.direction == horizontal) {
x++;
- for (; x < 15; x++) {
- if (board[x][y].childNodes.length == 0) {
- break;
- }
- }
} else {
y++;
- for (; y < 15; y++) {
- if (board[x][y].childNodes.length == 0) {
- break;
- }
- }
}
if ((x != 15) && (y != 15)) {
this.set(x, y);
@@ -239,8 +235,8 @@
var move = [];
-function makeMove(x, y, letter) {
- move[move.length] = [x, y, letter];
+function makeMove(x, y, letter, isBlank) {
+ move[move.length] = [x, y, letter, isBlank];
try {
checkMoveLegality(move);
$('move').onclick = submitMove;
@@ -299,9 +295,30 @@
var letter = specialKeyCodes[args[0]] || String.fromCharCode(args[0]);
var x = cursor.x;
var y = cursor.y;
- cursor.advance();
- setLetter(x, y, letter, true);
- makeMove(x, y, letter);
+ var tilePosition = -1;
+ for (var i = 0; (tilePosition == -1) && (i < tray.length); i++) {
+ if (tray[i].letter == letter) {
+ tilePosition = i;
+ }
+ }
+ if (tilePosition == -1) {
+ for (var i = 0; (tilePosition == -1) && (i < tray.length); i++) {
+ if (tray[i].letter == undefined) {
+ tilePosition = i;
+ }
+ }
+ }
+ if (tilePosition == -1) {
+ alert("You don't have that letter!");
+ } else {
+ cursor.advance();
+ if (!letterAt(x, y)) {
+ var tile = tray[tilePosition];
+ tray.splice(tilePosition, 1);
+ placeLetter(x, y, tile);
+ makeMove(x, y, letter, tile.letter == undefined);
+ }
+ }
}
var leftKey = 37;
@@ -358,8 +375,6 @@
}
}
-var tray;
-
function trayClick(letter) {
this.clicked = !this.clicked;
this.anim = new YAHOO.util.Motion(this, { points: { by: [ 0, (this.clicked ? 15 : -15 ) ]}}, 0.15);
@@ -367,6 +382,7 @@
}
function makeMyTray(letters) {
+ map(removeElement, tray);
tray = [];
for (var i = 0; i < letters.length; i++) {
var element = IMG({src: 'images/' + letters[i] + '.png'});
@@ -374,11 +390,13 @@
element.style.position = 'absolute';
element.style.width = '34px';
element.style.height = '34px';
+ element.style.zIndex = '10';
element.onclick = trayClick;
- setElementPosition(element, { x: i * 40 });
+ // setElementPosition(element, { x: border + 194 + i * 40, y: border + 665 });
+ YAHOO.util.Dom.setXY(element, [ border + 194 + i * 40, border + 665 ]);
tray[i] = element;
}
- replaceChildNodes(myTrayContainer, tray);
+ appendChildNodes($('playfield'), tray);
}
function shuffleMyTray() {
@@ -401,7 +419,7 @@
function addTheirTray (participant) {
appendChildNodes(theirTrays, DIV(null,
DIV(null, participant.name),
- DIV(null, map(function () { return IMG({ src: 'images/NIL.png' }) },
+ DIV(null, map(function () { return IMG({ src: 'images/null.png' }) },
new Array(participant.remainingTiles)))));
}
@@ -410,7 +428,7 @@
var x = gameState.board[i][0];
var y = gameState.board[i][1];
var char = gameState.board[i][2];
- setLetter(x, y, char);
+ setLetter(x, y, char, gameState.board[i].length > 3);
}
for (var i = 0; i < gameState.participants.length; i++) {
var participant = gameState.participants[i];
@@ -451,5 +469,5 @@
setElementPosition(moveDisplay, { x: border + 550, y: border + 665 });
appendChildNodes(document.body, moveDisplay);
var d = loadJSONDoc("/game/" + gameID);
- d.addCallbacks(drawGameState, alert);
+ d.addCallbacks(drawGameState, function (error) { alert("Request error: " + error.message); });
}
1
0
[bknr-cvs] r2284 - in branches/trunk-reorg/projects/scrabble: src website website/images/de website/images/en
by bknr＠bknr.net 17 Nov '07
by bknr＠bknr.net 17 Nov '07
17 Nov '07
Author: hhubner
Date: 2007-11-17 05:28:57 -0500 (Sat, 17 Nov 2007)
New Revision: 2284
Added:
branches/trunk-reorg/projects/scrabble/website/images/de/cursor.png
branches/trunk-reorg/projects/scrabble/website/images/de/mask.png
branches/trunk-reorg/projects/scrabble/website/images/en/cursor.png
branches/trunk-reorg/projects/scrabble/website/images/en/mask.png
Modified:
branches/trunk-reorg/projects/scrabble/src/make-letters.lisp
branches/trunk-reorg/projects/scrabble/website/scrabble.js
Log:
Cursor image, mask image for placed tiles, don't consider placed tiles
for move legality determination.
Modified: branches/trunk-reorg/projects/scrabble/src/make-letters.lisp
===================================================================
--- branches/trunk-reorg/projects/scrabble/src/make-letters.lisp 2007-11-15 14:10:11 UTC (rev 2283)
+++ branches/trunk-reorg/projects/scrabble/src/make-letters.lisp 2007-11-17 10:28:57 UTC (rev 2284)
@@ -1,43 +1,44 @@
-
(in-package :scrabble.graphics)
-(defparameter *special-tile-texts* (make-hash-table))
+(defparameter *special-field-texts* (make-hash-table))
-(setf (gethash :de *special-tile-texts*)
+(setf (gethash :de *special-field-texts*)
'(:double-letter "DOPPELTER
BUCHSTABEN
WERT"
- :double-word "DOPPELTER
+ :double-word "DOPPELTER
WORT
WERT"
- :triple-letter "DREIFACHER
+ :triple-letter "DREIFACHER
BUCHSTABEN
WERT"
- :triple-word "DREIFACHER
+ :triple-word "DREIFACHER
WORT
WERT"))
-(setf (gethash :en *special-tile-texts*)
+(setf (gethash :en *special-field-texts*)
'(:double-letter "DOUBLE
LETTER
SCORE"
- :double-word "DOUBLE
+ :double-word "DOUBLE
WORD
SCORE"
- :triple-letter "TRIPLE
+ :triple-letter "TRIPLE
LETTER
SCORE"
- :triple-word "TRIPLE
+ :triple-word "TRIPLE
WORD
SCORE"))
-(defparameter *special-tile-colors*
+(defparameter *special-field-colors*
'(:double-letter (0.53 0.8 0.94)
:double-word (0.97 0.67 0.6)
:triple-letter (0.0 0.62 0.87)
:triple-word (0.93 0.11 0.18)
:standard (0.0 0.59 0.57)))
+(defparameter *tile-color* '(1.0 0.98 0.8))
+
(defparameter *bold-font* #.(merge-pathnames #p"../fonts/DIN/DINMd___.ttf" *default-pathname-defaults*))
(defparameter *regular-font* #.(merge-pathnames #p"../fonts/DIN/DINRg___.ttf" *default-pathname-defaults*))
@@ -50,7 +51,7 @@
(char-name char)
char-string)
:type "png")))
- (set-rgb-fill 1.0 0.98 0.8)
+ (apply #'set-rgb-fill *tile-color*)
(rounded-rectangle 0 0 34 34 4 4)
(fill-path)
(when char
@@ -62,6 +63,13 @@
(save-png pathname)
pathname)))
+(defun make-mask-tile ()
+ (with-canvas (:width 34 :height 34)
+ (apply #'set-rgba-fill (append *tile-color* (list 0.5)))
+ (rounded-rectangle 0 0 34 34 4 4)
+ (fill-path)
+ (save-png #P"mask.png")))
+
(defun make-letter-tile-set (language)
(with-open-file (letter-map-file "charmap.xml"
:direction :output
@@ -76,7 +84,15 @@
(cxml:attribute "filename" (namestring (make-letter-tile letter score)))
(cxml:text (princ-to-string letter)))))))))
-(defun make-special-tile (name color &key text star)
+(defun make-cursor ()
+ (with-canvas (:width 46 :height 46)
+ (apply #'set-rgb-stroke *tile-color*)
+ (set-line-width 5)
+ (rounded-rectangle 4 4 38 38 5 5)
+ (stroke)
+ (save-png #P"cursor.png")))
+
+(defun make-special-field (name color &key text star)
(with-canvas (:width 40 :height 40)
(let ((regular-font (get-font *regular-font*)))
(apply #'set-rgb-fill color)
@@ -84,26 +100,25 @@
(fill-path)
(set-rgb-fill 0 0 0)
(cond
- (text
- (set-font regular-font 6)
+ (text
+ (set-font regular-font 6)
(let* ((lines (cl-ppcre:split "\\n" text))
(position (+ 20 (* 6 (/ 2 (length lines))))))
(dolist (line lines)
(draw-centered-string 20 position line)
(decf position 6))))
- (star
- ))
+ (star
+ ))
(save-png (make-pathname :name (string-downcase (symbol-name name)) :type "png")))))
-(defun make-special-tile-set (language)
+(defun make-special-field-set (language)
(dolist (tile-name '(:double-letter :double-word :triple-letter :triple-word))
- (make-special-tile tile-name
- (getf *special-tile-colors* tile-name)
- :text (getf (gethash language *special-tile-texts*) tile-name)))
- (make-special-tile :standard (getf *special-tile-colors* :standard) :star nil)
- (make-special-tile :standard (getf *special-tile-colors* :double-word) :star t))
+ (make-special-field tile-name
+ (getf *special-field-colors* tile-name)
+ :text (getf (gethash language *special-field-texts*) tile-name)))
+ (make-special-field :standard (getf *special-field-colors* :standard) :star nil)
+ (make-special-field :standard (getf *special-field-colors* :double-word) :star t))
-
(defun make-tile-set (directory language)
(let ((*default-pathname-defaults*
(merge-pathnames (merge-pathnames (make-pathname
@@ -111,5 +126,5 @@
directory))))
(ensure-directories-exist *default-pathname-defaults*)
(make-letter-tile-set language)
- (make-special-tile-set language)))
-
+ (make-special-field-set language)
+ (make-cursor)))
Added: branches/trunk-reorg/projects/scrabble/website/images/de/cursor.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/cursor.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/de/mask.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/de/mask.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/en/cursor.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/en/cursor.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/projects/scrabble/website/images/en/mask.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/projects/scrabble/website/images/en/mask.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Modified: branches/trunk-reorg/projects/scrabble/website/scrabble.js
===================================================================
--- branches/trunk-reorg/projects/scrabble/website/scrabble.js 2007-11-15 14:10:11 UTC (rev 2283)
+++ branches/trunk-reorg/projects/scrabble/website/scrabble.js 2007-11-17 10:28:57 UTC (rev 2284)
@@ -74,8 +74,8 @@
}
}
}
-
-
+
+
//
function getFieldScore(x, y) {
@@ -138,27 +138,35 @@
// appendChildNodes(container, clearButton);
}
-function setLetter(x, y, letter) {
+function setLetter(x, y, letter, justPlaced) {
var image = IMG({ src: 'images/' + letter + '.png'});
image.style.position = 'absolute';
image.style.top = '3px';
image.style.left = '3px';
replaceChildNodes(board[x][y], image);
+ if (justPlaced) {
+ var mask = IMG({ src: 'images/mask.png'});
+ mask.style.position = 'absolute';
+ mask.style.top = '3px';
+ mask.style.left = '3px';
+ appendChildNodes(board[x][y], mask);
+ }
board[x][y].letterNode = image;
board[x][y].letter = letter;
+ board[x][y].justPlaced = justPlaced;
YAHOO.util.Event.purgeElement(board[x][y], false, 'click');
}
function letterAt(x, y) {
- return board[x][y].letter;
+ return board[x][y].letter && !board[x][y].justPlaced;
}
function Cursor()
{
- var image = new IMG({ src: 'images/NIL.png' });
+ var image = new IMG({ src: 'images/cursor.png' });
image.style.position = 'absolute';
- image.style.top = '3px';
- image.style.left = '3px';
+ image.style.top = '-3px';
+ image.style.left = '-3px';
this.image = image;
this.x = -1;
@@ -233,12 +241,13 @@
function makeMove(x, y, letter) {
move[move.length] = [x, y, letter];
- $('move').onclick = submitMove;
- $('move').innerHTML = move.toString();
try {
checkMoveLegality(move);
+ $('move').onclick = submitMove;
+ $('move').innerHTML = move.toString();
}
catch (e) {
+ $('move').onclick = undefined;
$('move').innerHTML = e.toString();
}
}
@@ -291,7 +300,7 @@
var x = cursor.x;
var y = cursor.y;
cursor.advance();
- setLetter(x, y, letter);
+ setLetter(x, y, letter, true);
makeMove(x, y, letter);
}
@@ -304,7 +313,7 @@
function functionKeyPressed(type, args, obj) {
var x = cursor.x;
var y = cursor.y;
-
+
switch (args[0]) {
case rightKey:
while (x < 14)
1
0
15 Nov '07
Author: hhubner
Date: 2007-11-15 09:10:11 -0500 (Thu, 15 Nov 2007)
New Revision: 2283
Modified:
branches/trunk-reorg/bknr/datastore/src/data/txn.lisp
Log:
Remove redundant call to ensure-store-random-state
Modified: branches/trunk-reorg/bknr/datastore/src/data/txn.lisp
===================================================================
--- branches/trunk-reorg/bknr/datastore/src/data/txn.lisp 2007-11-15 07:42:51 UTC (rev 2282)
+++ branches/trunk-reorg/bknr/datastore/src/data/txn.lisp 2007-11-15 14:10:11 UTC (rev 2283)
@@ -79,7 +79,6 @@
(setf *store* store)
(let ((store-existed-p (probe-file (store-current-directory store))))
(ensure-store-current-directory store)
- (ensure-store-random-state store)
(dolist (subsystem (store-subsystems store))
(when *store-debug*
(format *trace-output* "Initializing subsystem ~A of ~A~%" subsystem store))
1
0
[bknr-cvs] r2282 - in branches/trunk-reorg/thirdparty: . hunchentoot-0.14.7 hunchentoot-0.14.7/doc hunchentoot-0.14.7/test slime slime/CVS slime/contrib slime/contrib/CVS slime/doc/CVS
by bknr＠bknr.net 15 Nov '07
by bknr＠bknr.net 15 Nov '07
15 Nov '07
Author: hhubner
Date: 2007-11-15 02:42:51 -0500 (Thu, 15 Nov 2007)
New Revision: 2282
Added:
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/CHANGELOG
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/CHANGELOG_TBNL
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/README
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/conditions.lisp
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/cookie.lisp
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/doc/
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/doc/LICENSE.txt
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/doc/hunchentoot.gif
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/doc/index.html
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/easy-handlers.lisp
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/headers.lisp
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/hunchentoot-test.asd
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/hunchentoot.asd
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/log.lisp
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/mime-types.lisp
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/misc.lisp
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/packages.lisp
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/port-acl.lisp
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/port-cmu.lisp
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/port-lw.lisp
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/port-mcl.lisp
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/port-sbcl.lisp
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/reply.lisp
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/request.lisp
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/server.lisp
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/session.lisp
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/specials.lisp
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/test/
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/test/UTF-8-demo.html
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/test/favicon.ico
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/test/fz.jpg
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/test/packages.lisp
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/test/test.lisp
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/unix-acl.lisp
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/unix-cmu.lisp
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/unix-lw.lisp
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/unix-mcl.lisp
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/unix-sbcl.lisp
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/util.lisp
Removed:
branches/trunk-reorg/thirdparty/hunchentoot-0.14.6/
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/doc/CVS/Entries
branches/trunk-reorg/thirdparty/slime/slime.el
branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp
branches/trunk-reorg/thirdparty/slime/swank-loader.lisp
branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp
branches/trunk-reorg/thirdparty/slime/swank.lisp
Log:
update hunchentoot
Added: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/CHANGELOG
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/CHANGELOG 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/CHANGELOG 2007-11-15 07:42:51 UTC (rev 2282)
@@ -0,0 +1,277 @@
+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.]
Property changes on: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/CHANGELOG
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/CHANGELOG_TBNL
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/CHANGELOG_TBNL 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/CHANGELOG_TBNL 2007-11-15 07:42:51 UTC (rev 2282)
@@ -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.14.7/README
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/README 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/README 2007-11-15 07:42:51 UTC (rev 2282)
@@ -0,0 +1,2 @@
+Complete documentation for Hunchentoot including details about how to
+install it can be found in the 'doc' directory.
Property changes on: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/README
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/conditions.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/conditions.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/conditions.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -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))
+
Property changes on: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/conditions.lisp
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/cookie.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/cookie.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/cookie.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -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.14.7/doc/LICENSE.txt
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/doc/LICENSE.txt 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/doc/LICENSE.txt 2007-11-15 07:42:51 UTC (rev 2282)
@@ -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/
Property changes on: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/doc/LICENSE.txt
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/doc/hunchentoot.gif
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/doc/hunchentoot.gif
___________________________________________________________________
Name: svn:executable
+ *
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/doc/index.html
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/doc/index.html 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/doc/index.html 2007-11-15 07:42:51 UTC (rev 2282)
@@ -0,0 +1,2614 @@
+<!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>
+</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>
+<br> <br><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>.
+
+<p>
+
+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 <em>not</em> 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>.
+
+<p>
+
+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 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.
+
+<p>
+
+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.
+<p>
+
+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>.
+
+<p>
+<font color=red>Download shortcut:</font> <a href="http://weitz.de/files/hunchentoot.tar.gz">http://weitz.de/files/hunchentoot.tar.gz</a>.
+</blockquote>
+
+<br> <br><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>
+
+<br> <br><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 <em>newest</em> 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> <em>before</em> you compile it.
+<p>
+The preferred method to compile and load Hunchentoot is via <a href="http://www.cliki.net/asdf">ASDF</a>.
+<p>
+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.14.7. 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.
+<p>
+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.
+<p>
+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.
+<p>
+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.)
+<p>
+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).
+<p>
+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.
+<p>
+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.)
+<p>
+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 <em>virtual hosts</em> or
+directives like <code>LocationMatch</code>.)
+
+<p>
+
+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.
+
+<br> <br><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 <b>search</b> the devel mailing
+list <a
+href="http://google.com/coop/cse?cx=002927904911724867201%3A0l5rif_cxj0">here</a>
+(thanks to Tiarn�n � Corr�in).
+<p>
+If you want to send patches, please <a href="http://weitz.de/patches.html">read this first</a>.
+
+<br> <br><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.
+<p>
+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.
+<p>
+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.
+</p>
+<p>
+Here is some software which extends Hunchentoot or is based on it:
+<ul>
+<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>
+
+<br> <br><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.
+
+<p><br>[Function]
+<br><a class=none name="start-server"><b>start-server</b> <i><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</i> => <i>server</i></a>
+
+<blockquote><br> Starts a Hunchentoot server instance and returns it.
+<code><i>port</i></code> ist the port the server will be listening on
+- the default is 80 (or 443 if SSL information is provided).
+If <code><i>address</i></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><i>address</i></code> is <code>NIL</code>, then the server
+will receive connections to all IP addresses on the machine. This is
+the default.
+<p>
+<code><i>dispatch-table</i></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.
+<p>
+<code><i>name</i></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>.
+<p>
+If <code><i>mod-lisp-p</i></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><i>use-apache-log-p</i></code> is
+true (which is the default), log messages will be written to the
+Apache log file - this parameter has no effect
+if <code><i>mod-lisp-p</i></code> is NIL.
+<p>
+If <code><i>input-chunking-p</i></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>.
+<p>
+<code><i>read-timeout</i></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><i>write-timeout</i></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><i>mod-lisp-p</i></code> is true, the timeouts are always set
+to <code>NIL</code>.
+<p>
+On Unix you can use <code><i>setuid</i></code>
+and <code><i>setgid</i></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><i>setuid</i></code> and
+<code><i>setgid</i></code> can be integers (the actual IDs) or strings
+(for the user and group name respectively).
+<p>
+If you want your server to use SSL, you must provide the pathname
+designator(s) <code><i>ssl-certificate-file</i></code> for the certificate file and
+optionally <code><i>ssl-privatekey-file</i></code> for the private key file, both files
+must be in PEM format. If you only provide the value for
+<code><i>ssl-certificate-file</i></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><i>ssl-privatekey-password</i></code> keyword argument. If
+you <em>don't</em> 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>
+
+<p><br>[Function]
+<br><a class=none name="stop-server"><b>stop-server</b> <i>server</i> => |</a>
+
+<blockquote><br>
+Stops a server started with <a href="#start-server"><code>START-SERVER</code></a>. <code><i>server</i></code> must be an object as returned by <a href="#start-server"><code>START-SERVER</code></a>.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*server*"><b>*server*</b></a>
+
+<blockquote><br>
+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>
+
+<p><br>[Readers]
+<br><a class=none name="server-local-port"><b>server-local-port</b> <i>server</i> => <i>port</i></a>
+<br><a class=none name="server-address"><b>server-address</b> <i>server</i> => <i>address</i></a>
+
+<blockquote><br>
+These methods can be used to query a Hunchentoot server object. The values correspond to the <code><i>port</i></code> and <code><i>address</i></code> parameters of <a href="#start-server"><code>START-SERVER</code></a>.
+</blockquote>
+
+<p><br>[Accessor]
+<br><a class=none name="server-dispatch-table"><b>server-dispatch-table</b> <i>server</i> => <i>dispatch-table</i>
+<br><tt>(setf (</tt><b>server-dispatch-table</b> <i>server</i>) <i>new-value</i><tt>)</tt></a>
+
+<blockquote><br> 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><i>dispatch-table</i></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>
+
+<p><br>[Accessor]
+<br><a class=none name="server-name"><b>server-name</b> <i>server</i> => <i>name</i>
+<br><tt>(setf (</tt><b>server-name</b> <i>server</i>) <i>new-value</i><tt>)</tt></a>
+<blockquote><br> These methods can be used to get and set the name of a server
+which must be a symbol.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*default-read-timeout*"><b>*default-read-timeout*</b></a>
+
+<blockquote><br> The default value for the <code><i>read-timeout</i></code> keyword
+argument to <a href="#start-server"><code>START-SERVER</code></a>. The initial value is 20 (seconds).
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*default-write-timeout*"><b>*default-write-timeout*</b></a>
+
+<blockquote><br> The default value for the <code><i>write-timeout</i></code> keyword
+argument to <a href="#start-server"><code>START-SERVER</code></a>. The initial value is 20 (seconds).
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*cleanup-interval*"><b>*cleanup-interval*</b></a>
+
+<blockquote><br>
+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>
+
+<p><br>[Special variable]
+<br><a class=none name="*cleanup-function*"><b>*cleanup-function*</b></a>
+
+<blockquote><br>
+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.
+<p>
+On LispWorks this is necessary because each <em>worker</em> (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.
+<p>
+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 <em>dispatch table</em>. The details can be found
+below. (See the file <code>test/test.lisp</code> for examples.)
+
+<p><br>[Special variable]
+<br><a class=none name="*dispatch-table*"><b>*dispatch-table*</b></a>
+
+<blockquote><br>
+
+The return value of the initial value of <a href="#*meta-dispatcher*"><code>*META-DISPATCHER*</code></a>.
+<p>
+This is a list of <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function…">function
+designators</a> for <em>dispatch functions</em> 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 <em>handler</em> to handle the
+request or <code>NIL</code> which means that the next dispatcher will
+be queried. A <em>handler</em> 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.
+<p>
+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.
+<p>
+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>
+
+<p><br>[Function]
+<br><a class=none name="default-dispatcher"><b>default-dispatcher</b> <i>request</i> => <i>handler</i></a>
+
+<blockquote><br>
+
+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>
+
+<p><br>[Special variable]
+<br><a class=none name="*default-handler*"><b>*default-handler*</b></a>
+
+<blockquote><br>
+
+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>
+
+<p><br>[Special variable]
+<br><a class=none name="*meta-dispatcher*"><b>*meta-dispatcher*</b></a>
+
+<blockquote><br> 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>.
+<p>
+This can obviously be used to assign different dispatch tables to
+different servers (and is useless if you only have one server).
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="create-prefix-dispatcher"><b>create-prefix-dispatcher</b> <i>prefix handler</i> => <i>dispatch-fn</i></a>
+
+<blockquote><br>
+
+A convenience function which will return a dispatcher that returns <code><i>handler</i></code> whenever the path part of the request URI starts with the string <code><i>prefix</i></code>.
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="create-regex-dispatcher"><b>create-regex-dispatcher</b> <i>regex handler</i> => <i>dispatch-fn</i></a>
+
+<blockquote><br>
+
+A convenience function which will return a dispatcher that returns <code><i>handler</i></code> whenever the path part of the request URI matches the <a href='http://weitz.de/cl-ppcre/'>CL-PPCRE</a> regular expression <code><i>regex</i></code> (which can be a string, an s-expression, or a scanner).
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="handle-static-file"><b>handle-static-file</b> <i>path <tt>&optional</tt> content-type</i> => <i>nil</i></a>
+
+<blockquote><br>
+Sends the file denote by the pathname designator
+<code><i>path</i></code> with content type
+<code><i>content-type</i></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>.
+<p>
+If <code><i>content-type</i></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.
+<p>
+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>
+
+<p><br>[Function]
+<br><a class=none name="create-static-file-dispatcher-and-handler"><b>create-static-file-dispatcher-and-handler</b> <i>uri path <tt>&optional</tt> content-type</i> => <i>dispatch-fn</i></a>
+
+<blockquote><br>
+
+A convenience function which will return a dispatcher that dispatches
+to a handler which emits the file denoted by the pathname designator
+<code><i>path</i></code> with content type
+<code><i>content-type</i></code>
+if the <a href='#script-name'><code>SCRIPT-NAME</code></a> of the
+request matches the string <code><i>uri</i></code>. Uses <a href="#handle-static-file"><code>HANDLE-STATIC-FILE</code></a> internally.
+<p>
+If <code><i>content-type</i></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>
+
+<p><br>[Function]
+<br><a class=none name="create-folder-dispatcher-and-handler"><b>create-folder-dispatcher-and-handler</b> <i>uri-prefix base-path <tt>&optional</tt> content-type</i> => <i>dispatch-fn</i></a>
+
+<blockquote><br>
+Creates and returns a dispatch function which will dispatch to a
+handler function which emits the file relative to <code><i>base-path</i></code> that is
+denoted by the URI of the request relative to <code><i>uri-prefix</i></code>. <code><i>uri-prefix</i></code>
+must be a string ending with a slash, <code><i>base-path</i></code> must be a pathname
+designator for an existing directory.
+Uses <a href="#handle-static-file"><code>HANDLE-STATIC-FILE</code></a> internally.
+<p>
+If <code><i>content-type</i></code> is <em>not</em> <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>
+
+<p><br>[Generic function]
+<br><a class=none name="dispatch-request"><b>dispatch-request</b> <i>dispatch-table</i> => <i>result</i></a>
+
+<blockquote><br>
+This is a generic function so users can customize its behaviour. Look at the source code for details.
+</blockquote>
+
+<p><br>[Macro]
+<br><a class=none name="define-easy-handler"><b>define-easy-handler</b> <i>description lambda-list [[declaration* | documentation]] form*</i></a>
+
+<blockquote><br>
+
+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>.
+<p>
+<code><i>description</i></code> is either a symbol <code><i>name</i></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><i>lambda-list</i></code> is a list the elements of which are either a symbol
+<code><i>var</i></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><i>name</i></code> and keyword parameters named by
+the <code><i>var</i></code> symbols. Each <code><i>var</i></code>
+will be bound to the value of the GET or POST parameter
+called <code><i>real-name</i></code> (a string) before the body of the
+function is executed. If <code><i>real-name</i></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><i>var</i></code>.
+<p>
+If <code><i>uri</i></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><i>uri</i></code> is a
+string and the <a href="#script-name">script name</a> of the current request is <code><i>uri</i></code>, or if <code><i>uri</i></code> designates a
+function and applying this function to the <a href="#*request*">current <code>REQUEST</code> object</a>
+returns a true value.
+<p>
+
+<code><i>server-names</i></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><i>server-names</i></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 <em>every</em> server.
+<p>
+Whether the GET or POST parameter (or both) will be taken into
+consideration, depends on <code><i>request-type</i></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><i>default-request-type</i></code> (the default of which
+is <code>:BOTH</code>) will be used.
+<p>
+The value of <code><i>var</i></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><i>parameter-type</i></code> (which is evaluated)
+is provided, the string will be converted to another Lisp type by the
+following rules:
+<p>
+If the corresponding GET or POST parameter wasn't provided by the
+client, <code><i>var</i></code>'s value will be <code>NIL</code>. If <code><i>parameter-type</i></code> is <code>'STRING</code>,
+<code><i>var</i></code>'s value remains as is. If <code><i>parameter-type</i></code> is <code>'INTEGER</code> and the
+parameter string consists solely of decimal digits, <code><i>var</i></code>'s value will be
+the corresponding integer, otherwise <code>NIL</code>. If <code><i>parameter-type</i></code> is
+<code>'KEYWORD</code>, <code><i>var</i></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><i>parameter-type</i></code>
+is <code>'CHARACTER</code> and the parameter string is of length
+one, <code><i>var</i></code>'s value will be the single character of
+this string, otherwise <code>NIL</code>.
+If <code><i>parameter-type</i></code>
+is <code>'BOOLEAN</code>, <code><i>var</i></code>'s value will always
+be <code>T</code> (unless it is <code>NIL</code> by the first rule
+above, of course). If <code><i>parameter-type</i></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.
+<p>
+Those were the rules for <em>simple</em> parameter types, but
+<code><i>parameter-type</i></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 <em>inner type</em> below.
+<p>
+In the case of <code>'LIST</code>, all GET/POST parameters
+called <code><i>real-name</i></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><i>var</i></code>.
+<p>
+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><i>n</i></code> is a non-negative integer, will be
+assembled into an array where the <code><i>n</i></code>th element will
+be set accordingly, after conversion to the inner type. The array,
+which will become the value of <code><i>var</i></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.
+<p>
+The full form of a <code>'HASH-TABLE</code> parameter type is
+
+<pre>
+ (hash-table inner-type key-type test-function),
+</pre>
+
+but <code><i>key-type</i></code> and <code><i>test-function</i></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><i>key</i></code> is a string that doesn't contain curly brackets) will
+become the values (after conversion to <code><i>inner-type</i></code>) of a hash
+table with test function <code><i>test-function</i></code> where <code><i>key</i></code> (after
+conversion to <code><i>key-type</i></code>) will be the corresponding key. Note that
+<code><i>var</i></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.
+<p>
+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>.
+<p>
+If <code><i>parameter-type</i></code> is not provided
+or <code>NIL</code>, <code><i>default-parameter-type</i></code> (the
+default of which is <code>'STRING</code>) will be used instead.
+<p>
+If the result of the computations above would be
+that <code><i>var</i></code> would be bound to <code>NIL</code>,
+then <code><i>init-form</i></code> (if provided) will be evaluated
+instead, and <code><i>var</i></code> will be bound to the result of
+this evaluation.
+<p>
+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><i>var</i></code> will
+always be bound to the result of
+evaluating <code><i>init-form</i></code> unless a corresponding
+keyword argument is provided.
+<p>
+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>
+
+<p><br>[Function]
+<br><a class=none name="dispatch-easy-handlers"><b>dispatch-easy-handlers</b> <i>request</i> => <i>handler</i></a>
+
+<blockquote><br>
+
+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.
+<p>
+In all of the functions below, the default value
+for <code><i>request</i></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.
+<p>
+(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.)
+
+<p><br>[Special variable]
+<br><a class=none name="*request*"><b>*request*</b></a>
+
+<blockquote><br>
+
+Holds the current <code>REQUEST</code> object.
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="host"><b>host</b> <i><tt>&optional</tt> request</i> => <i>string</i></a>
+
+<blockquote><br>
+
+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>
+
+<p><br>[Function]
+<br><a class=none name="request-method"><b>request-method</b> <i><tt>&optional</tt> request</i> => <i>keyword</i></a>
+
+<blockquote><br>
+
+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>
+
+<p><br>[Function]
+<br><a class=none name="request-uri"><b>request-uri</b> <i><tt>&optional</tt> request</i> => <i>string</i></a>
+
+<blockquote><br>
+
+Returns the URI for <code><i>request</i></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>
+
+<p><br>[Function]
+<br><a class=none name="script-name"><b>script-name</b> <i><tt>&optional</tt> request</i> => <i>string</i></a>
+
+<blockquote><br>
+
+Returns the file name (or path) component of the URI
+for <code><i>request</i></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>
+
+<p><br>[Function]
+<br><a class=none name="query-string"><b>query-string</b> <i><tt>&optional</tt> request</i> => <i>string</i></a>
+
+<blockquote><br>
+
+Returns the query component of the URI
+for <code><i>request</i></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>
+
+<p><br>[Function]
+<br><a class=none name="get-parameter"><b>get-parameter</b> <i>name <tt>&optional</tt> request</i> => <i>string</i></a>
+
+<blockquote><br>
+Returns the value of the GET parameter (as provided via the request URI) named by the string <code><i>name</i></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><i>name</i></code>. See also <a href="#get-parameters"><code>GET-PARAMETERS</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="get-parameters"><b>get-parameters</b> <i><tt>&optional</tt> request</i> => <i>alist</i></a>
+
+<blockquote><br>
+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>
+
+<p><br>[Function]
+<br><a class=none name="post-parameter"><b>post-parameter</b> <i>name <tt>&optional</tt> request</i> => <i>string</i></a>
+
+<blockquote><br>
+Returns the value of the POST parameter (as provided in the request's body) named by the string <code><i>name</i></code>. Note that only the first value will be returned if the client provided more than one POST parameter with the name <code><i>name</i></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><i>path</i></code> is a pathname denoting the place were the uploaded file was stored, <code><i>file-name</i></code> (a string) is the file name sent by the browser, and <code><i>content-type</i></code> (also a string) is the content type sent by the browser. The file denoted by <code><i>path</i></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.
+<p>
+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>.
+<p>
+See also <a href="#post-parameters"><code>POST-PARAMETERS</code></a> and <a href="#*tmp-directory*"><code>*TMP-DIRECTORY*</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="post-parameters"><b>post-parameters</b> <i><tt>&optional</tt> request</i> => <i>alist</i></a>
+
+<blockquote><br>
+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.
+<p>
+See also <a href="#post-parameter"><code>POST-PARAMETER</code></a>.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*methods-for-post-parameters*"><b>*methods-for-post-parameters*</b></a>
+
+<blockquote><br> 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>
+
+<p><br>[Special variable]
+<br><a class=none name="*file-upload-hook*"><b>*file-upload-hook*</b></a>
+
+<blockquote><br> 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 <em>before</em> 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>
+
+<p><br>[Function]
+<br><a class=none name="raw-post-data"><b>raw-post-data</b> <tt>&key</tt> <i>request external-format force-text force-binary want-stream</i> => <i>raw-body-or-stream</i></a>
+
+<blockquote><br> 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).
+<p>
+You can also provide an external format explicitly (through
+<code><i>external-format</i></code>) in which case the result will
+unconditionally be a string. Likewise, you can provide a true value
+for <code><i>force-text</i></code> which will force Hunchentoot to act
+as if the type of the media type had been <code>"text"</code>
+(with <code><i>external-format</i></code> taking precedence if
+provided). Or you can provide a true value
+for <code><i>force-binary</i></code> which means that you want a
+vector of octets at any rate. (If both
+<code><i>force-text</i></code> and <code><i>force-binary</i></code>
+are true, an error will be signaled.)
+<p>
+If, however, you provide a true value
+for <code><i>want-stream</i></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.
+<p>
+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.
+<p>
+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><i>want-stream</i></code>.
+<p>
+Note that this function is slightly misnamed because a client can send
+content even if the request method is not POST.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="parameter"><b>parameter</b> <i>name <tt>&optional</tt> request</i> => <i>string</i></a>
+
+<blockquote><br>
+Returns the value of the GET or POST parameter named by the string <code><i>name</i></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><i>name</i></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>
+
+<p><br>[Function]
+<br><a class=none name="header-in"><b>header-in</b> <i>name <tt>&optional</tt> request</i> => <i>string</i></a>
+
+<blockquote><br> Returns the incoming header named by the
+keyword <code><i>name</i></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 <em>or</em> 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>.
+<p>For backwards compatibility, <code><i>name</i></code>
+can also be a string which is matched case-insensitively. See
+also <a href="#headers-in"><code>HEADERS-IN</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="headers-in"><b>headers-in</b> <i><tt>&optional</tt> request</i> => <i>alist</i></a>
+
+<blockquote><br>
+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>
+
+<p><br>[Function]
+<br><a class=none name="authorization"><b>authorization</b> <i><tt>&optional</tt> request</i> => <i>user, password</i></a>
+
+<blockquote><br>
+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>
+
+
+<p><br>[Function]
+<br><a class=none name="remote-addr"><b>remote-addr</b> <i><tt>&optional</tt> request</i> => <i>string</i></a>
+
+<blockquote><br>
+
+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>
+
+<p><br>[Function]
+<br><a class=none name="remote-port"><b>remote-port</b> <i><tt>&optional</tt> request</i> => <i>number</i></a>
+
+<blockquote><br>
+
+Returns the IP port (as a number) of the client which sent the request.
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="real-remote-addr"><b>real-remote-addr</b> <i><tt>&optional</tt> request</i> => <i>string{, list}</i></a>
+
+<blockquote><br>
+
+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>
+
+<p><br>[Function]
+<br><a class=none name="server-addr"><b>server-addr</b> <i><tt>&optional</tt> request</i> => <i>string</i></a>
+
+<blockquote><br>
+
+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>
+
+<p><br>[Function]
+<br><a class=none name="server-port"><b>server-port</b> <i><tt>&optional</tt> request</i> => <i>number</i></a>
+
+<blockquote><br>
+
+Returns the IP port (as a number) where the request came in.
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="server-protocol"><b>server-protocol</b> <i><tt>&optional</tt> request</i> => <i>keyword</i></a>
+
+<blockquote><br>
+
+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>
+
+<p><br>[Function]
+<br><a class=none name="mod-lisp-id"><b>mod-lisp-id</b> <i><tt>&optional</tt> request</i> => <i>string</i></a>
+
+<blockquote><br>
+
+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>
+
+<p><br>[Function]
+<br><a class=none name="ssl-session-id"><b>ssl-session-id</b> <i><tt>&optional</tt> request</i> => <i>string</i></a>
+
+<blockquote><br>
+
+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>
+
+<p><br>[Function]
+<br><a class=none name="user-agent"><b>user-agent</b> <i><tt>&optional</tt> request</i> => <i>string</i></a>
+
+<blockquote><br>
+
+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>
+
+<p><br>[Function]
+<br><a class=none name="referer"><b>referer</b> <i><tt>&optional</tt> request</i> => <i>string</i></a>
+
+<blockquote><br>
+
+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>
+
+<p><br>[Function]
+<br><a class=none name="cookie-in"><b>cookie-in</b> <i>name <tt>&optional</tt> request</i> => <i>string</i></a>
+
+<blockquote><br>
+Returns the value of the incoming cookie named by the string <code><i>name</i></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>
+
+<p><br>[Function]
+<br><a class=none name="cookies-in"><b>cookies-in</b> <i><tt>&optional</tt> request</i> => <i>alist</i></a>
+
+<blockquote><br>
+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>
+
+<p><br>[Accessor]
+<br><a class=none name="aux-request-value"><b>aux-request-value</b> <i>symbol <tt>&optional</tt> request</i> => <i>value, present-p</i>
+<br><tt>(setf (</tt><b>aux-request-value</b> <i>symbol <tt>&optional</tt> request</i>) <i>new-value</i><tt>)</tt></a>
+
+<blockquote><br>
+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><i>symbol</i></code> in the <code>REQUEST</code>
+object <code><i>request</i></code>.
+<code><i>present-p</i></code> is <em>true</em> if such data was found,
+otherwise <code>NIL</code>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="delete-aux-request-value"><b>delete-aux-request-value</b> <i>symbol <tt>&optional</tt> request</i> => |</a>
+
+<blockquote><br>
+Completely removes any data associated with the <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#symbol">symbol</a> <code><i>symbol</i></code> from the <code>REQUEST</code>
+object <code><i>request</i></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>
+
+<p><br>[Function]
+<br><a class=none name="recompute-request-parameters"><b>recompute-request-parameters</b> <i><tt>&key</tt> request external-format</i> => |</a>
+
+<blockquote><br> Recomputes the GET and POST parameters for
+the <code>REQUEST</code> object
+<code><i>request</i></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.
+<p>
+The default value for
+<code><i>external-format</i></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.
+<p>
+In all of the functions below, the default value
+for the optional argument <code><i>reply</i></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.
+<p>
+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.
+
+<p><br>[Special variable]
+<br><a class=none name="*reply*"><b>*reply*</b></a>
+
+<blockquote><br>
+
+Holds the current <code>REPLY</code> object.
+
+</blockquote>
+
+<p><br>[Accessor]
+<br><a class=none name="header-out"><b>header-out</b> <i>name <tt>&optional</tt> reply</i> => <i>string</i>
+<br><tt>(setf (</tt><b>header-out</b> <i>name <tt>&optional</tt> reply</i>) <i>new-value</i><tt>)</tt></a>
+
+<blockquote><br>
+
+<code>HEADER-OUT</code> returns the outgoing http header named by the
+keyword <code><i>name</i></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><i>name</i></code>. If no header
+named <code><i>name</i></code> exists it is created. For backwards
+compatibility, <code><i>name</i></code> can also be a string in which
+case the association between a header and its name is
+case-insensitive.
+<p>
+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 <em>must not</em> 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>.
+<p>
+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>
+
+<p><br>[Function]
+<br><a class=none name="headers-out"><b>headers-out</b> <i><tt>&optional</tt> request</i> => <i>alist</i></a>
+
+<blockquote><br>
+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>
+
+<p><br>[Function]
+<br><a class=none name="cookie-out"><b>cookie-out</b> <i>name <tt>&optional</tt> reply</i> => <i>cookie</i></a>
+
+<blockquote><br>
+Returns the outgoing cookie named by the string <code><i>name</i></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>
+
+<p><br>[Function]
+<br><a class=none name="cookies-out"><b>cookies-out</b> <i><tt>&optional</tt> reply</i> => <i>alist</i></a>
+
+<blockquote><br>
+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>
+
+<p><br>[Accessor]
+<br><a class=none name="return-code"><b>return-code</b> <i><tt>&optional</tt> reply</i> => <i>number</i>
+<br><tt>(setf (</tt><b>return-code</b> <i><tt>&optional</tt> reply</i>) <i>new-value</i><tt>)</tt></a>
+
+<blockquote><br>
+
+<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>
+
+<p><br>[Accessor]
+<br><a class=none name="content-type"><b>content-type</b> <i><tt>&optional</tt> reply</i> => <i>string</i>
+<br><tt>(setf (</tt><b>content-type</b> <i><tt>&optional</tt> reply</i>) <i>new-value</i><tt>)</tt></a>
+
+<blockquote><br>
+
+<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>
+
+<p><br>[Accessor]
+<br><a class=none name="content-length"><b>content-length</b> <i><tt>&optional</tt> reply</i> => <i>length</i>
+<br><tt>(setf (</tt><b>content-length</b> <i><tt>&optional</tt> reply</i>) <i>new-value</i><tt>)</tt></a>
+
+<blockquote><br>
+
+<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 <em>must</em> make sure that it's
+the correct length of the body in <em>octets</em> (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.
+<p>
+Note that setting this value explicitly doesn't mix well with <a
+href="#*rewrite-for-session-urls*">URL rewriting</a>.
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="send-headers"><b>send-headers</b> => <i>stream</i></a>
+
+<blockquote><br>
+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.
+<p>
+If your handlers return the full body as a string or as an array of
+octets, you should <em>not</em> call this function. If a handler
+calls <a href="#send-headers"><code>SEND-HEADERS</code></a>, its return
+value is ignored.
+<p>
+See also <a href="#reply-external-format"><code>REPLY-EXTERNAL-FORMAT</code></a>.
+</blockquote>
+
+<p><br>[Accessor]
+<br><a class=none name="reply-external-format"><b>reply-external-format</b> <i><tt>&optional</tt> reply</i> => <i>external-format</i>
+<br><tt>(setf (</tt><b>reply-external-format</b> <i><tt>&optional</tt> reply</i>) <i>new-value</i><tt>)</tt></a>
+
+<blockquote><br>
+
+Gets and sets the external format of the <code>REPLY</code>
+object <code><i>reply</i></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>).
+<p>The initial value for each request is the value
+of <a
+href="#*hunchentoot-default-external-format*"><code>*HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*</code></a>.
+
+</blockquote>
+
+<p><br>[Constants]
+<br><a class=none name='+http-continue+'><b>+http-continue+</b></a>
+<br><a class=none name='+http-switching-protocols+'><b>+http-switching-protocols+</b></a>
+<br><a class=none name='+http-ok+'><b>+http-ok+</b></a>
+<br><a class=none name='+http-created+'><b>+http-created+</b></a>
+<br><a class=none name='+http-accepted+'><b>+http-accepted+</b></a>
+<br><a class=none name='+http-non-authoritative-information+'><b>+http-non-authoritative-information+</b></a>
+<br><a class=none name='+http-no-content+'><b>+http-no-content+</b></a>
+<br><a class=none name='+http-reset-content+'><b>+http-reset-content+</b></a>
+<br><a class=none name='+http-partial-content+'><b>+http-partial-content+</b></a>
+<br><a class=none name='+http-multi-status+'><b>+http-multi-status+</b></a>
+<br><a class=none name='+http-multiple-choices+'><b>+http-multiple-choices+</b></a>
+<br><a class=none name='+http-moved-permanently+'><b>+http-moved-permanently+</b></a>
+<br><a class=none name='+http-moved-temporarily+'><b>+http-moved-temporarily+</b></a>
+<br><a class=none name='+http-see-other+'><b>+http-see-other+</b></a>
+<br><a class=none name='+http-not-modified+'><b>+http-not-modified+</b></a>
+<br><a class=none name='+http-use-proxy+'><b>+http-use-proxy+</b></a>
+<br><a class=none name='+http-temporary-redirect+'><b>+http-temporary-redirect+</b></a>
+<br><a class=none name='+http-bad-request+'><b>+http-bad-request+</b></a>
+<br><a class=none name='+http-authorization-required+'><b>+http-authorization-required+</b></a>
+<br><a class=none name='+http-payment-required+'><b>+http-payment-required+</b></a>
+<br><a class=none name='+http-forbidden+'><b>+http-forbidden+</b></a>
+<br><a class=none name='+http-not-found+'><b>+http-not-found+</b></a>
+<br><a class=none name='+http-method-not-allowed+'><b>+http-method-not-allowed+</b></a>
+<br><a class=none name='+http-not-acceptable+'><b>+http-not-acceptable+</b></a>
+<br><a class=none name='+http-proxy-authentication-required+'><b>+http-proxy-authentication-required+</b></a>
+<br><a class=none name='+http-request-time-out+'><b>+http-request-time-out+</b></a>
+<br><a class=none name='+http-conflict+'><b>+http-conflict+</b></a>
+<br><a class=none name='+http-gone+'><b>+http-gone+</b></a>
+<br><a class=none name='+http-length-required+'><b>+http-length-required+</b></a>
+<br><a class=none name='+http-precondition-failed+'><b>+http-precondition-failed+</b></a>
+<br><a class=none name='+http-request-entity-too-large+'><b>+http-request-entity-too-large+</b></a>
+<br><a class=none name='+http-request-uri-too-large+'><b>+http-request-uri-too-large+</b></a>
+<br><a class=none name='+http-unsupported-media-type+'><b>+http-unsupported-media-type+</b></a>
+<br><a class=none name='+http-requested-range-not-satisfiable+'><b>+http-requested-range-not-satisfiable+</b></a>
+<br><a class=none name='+http-expectation-failed+'><b>+http-expectation-failed+</b></a>
+<br><a class=none name='+http-failed-dependency+'><b>+http-failed-dependency+</b></a>
+<br><a class=none name='+http-internal-server-error+'><b>+http-internal-server-error+</b></a>
+<br><a class=none name='+http-not-implemented+'><b>+http-not-implemented+</b></a>
+<br><a class=none name='+http-bad-gateway+'><b>+http-bad-gateway+</b></a>
+<br><a class=none name='+http-service-unavailable+'><b>+http-service-unavailable+</b></a>
+<br><a class=none name='+http-gateway-time-out+'><b>+http-gateway-time-out+</b></a>
+<br><a class=none name='+http-version-not-supported+'><b>+http-version-not-supported+</b></a>
+
+<blockquote><br>
+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>
+
+<p><br>[Special variable]
+<br><a class=none name='*default-content-type*'><b>*default-content-type*</b></a>
+
+<blockquote><br>
+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.
+
+<p><br>[Function]
+<br><a class=none name="set-cookie"><b>set-cookie</b> <i>name <tt>&key</tt> value expires path domain secure http-only reply</i> => <i>cookie</i></a>
+
+<blockquote><br> 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><i>reply</i></code>. If a cookie with the same name
+(case-sensitive) already exists, it is replaced. The default
+for <code><i>reply</i></code> is <a
+href="#*reply*"><code>*REPLY*</code></a>. The default for <code><i>value</i></code> is the empty string.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="set-cookie*"><b>set-cookie*</b> <i>cookie <tt>&optional</tt> reply</i> => <i>cookie</i></a>
+
+<blockquote><br> Adds the <code>COOKIE</code>
+object <code><i>cookie</i></code> to the outgoing cookies of the <a
+href='#replies'><code>REPLY</code>
+object</a> <code><i>reply</i></code>. If a cookie with the same name
+(case-sensitive) already exists, it is replaced. The default for <code><i>reply</i></code> is <a href="#*reply*"><code>*REPLY*</code></a>.
+</blockquote>
+
+<h4><a class=none name="sessions">Sessions</a></h4>
+
+Hunchentoot supports <em>sessions</em>: 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.
+<p>
+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!
+<p>
+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.
+<p>
+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>.
+
+<p><br>[Special variable]
+<br><a class=none name="*session*"><b>*session*</b></a>
+
+<blockquote><br>
+
+Holds the current <code>SESSION</code> object (if any) or <code>NIL</code>.
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="start-session"><b>start-session</b> => <i>session</i></a>
+
+<blockquote><br> 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>
+
+<p><br>[Accessor]
+<br><a class=none name="session-value"><b>session-value</b> <i>symbol <tt>&optional</tt> session</i> => <i>value, present-p</i>
+<br><tt>(setf (</tt><b>session-value</b> <i>symbol <tt>&optional</tt> session</i>) <i>new-value</i><tt>)</tt></a>
+
+<blockquote><br>
+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><i>symbol</i></code> in the <code>SESSION</code>
+object <code><i>session</i></code>.
+<code><i>present-p</i></code> is <em>true</em> if such data was found,
+otherwise <code>NIL</code>. The default value
+for <code><i>session</i></code> is <a
+href="#*session*"><code>*SESSION*</code></a>.
+<p>
+If <code>SETF</code> of <code>SESSION-VALUE</code> is called with <code><i>session</i></code> being <code>NIL</code> then a session is automatically instantiated with <a href="#start-session"><code>START-SESSION</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="delete-session-value"><b>delete-session-value</b> <i>symbol <tt>&optional</tt> session</i> => |</a>
+
+<blockquote><br>
+Completely removes any data associated with the <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#symbol">symbol</a> <code><i>symbol</i></code> from the <code>SESSION</code>
+object <code><i>session</i></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><i>session</i></code> is <a
+href="#*session*"><code>*SESSION*</code></a>.
+</blockquote>
+
+
+<p><br>[Function]
+<br><a class=none name="remove-session"><b>remove-session</b> <i>session</i> => |</a>
+
+<blockquote><br>
+Completely removes the session <code><i>session</i></code> from Hunchentoot's internal session database. See also <a href="#*session-removal-hook*"><code>*SESSION-REMOVAL-HOOK*</code></a>.
+</blockquote>
+
+
+<p><br>[Function]
+<br><a class=none name="reset-sessions"><b>reset-sessions</b> => |</a>
+
+<blockquote><br>
+This function unconditionally invalidates and destroys <em>all</em> sessions immediately.
+</blockquote>
+
+
+<p><br>[Function]
+<br><a class=none name="session-cookie-value"><b>session-cookie-value</b> <i>session</i> => <i>string</i></a>
+
+<blockquote><br>
+Returns a unique string that's associated with
+the <code>SESSION</code> object <code><i>session</i></code>. This
+string is sent to the browser as a cookie value or as a GET parameter,
+</blockquote>
+
+
+<p><br>[Function]
+<br><a class=none name="session-counter"><b>session-counter</b> <i>session</i> => <i>count</i></a>
+
+<blockquote><br>
+Returns the number of times (requests) the <code>SESSION</code> object <code><i>session</i></code> has been used.
+</blockquote>
+
+
+
+<p><br>[Accessor]
+<br><a class=none name="session-max-time"><b>session-max-time</b> <i>session</i> => <i>seconds</i>
+<br><tt>(setf (</tt><b>session-max-time</b> <i>session</i>) <i>seconds</i><tt>)</tt></a>
+
+<blockquote><br> This gets or sets the maximum time (in seconds)
+the <code>SESSION</code> object <code><i>session</i></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><i>seconds</i></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>
+
+<p><br>[Function]
+<br><a class=none name="session-remote-addr"><b>session-remote-addr</b> <i>session</i> => <i>address</i></a>
+
+<blockquote><br> 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><i>session</i></code> was initiated.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="session-user-agent"><b>session-user-agent</b> <i>session</i> => <i>address</i></a>
+
+<blockquote><br> 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><i>session</i></code> was initiated.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*use-remote-addr-for-sessions*"><b>*use-remote-addr-for-sessions*</b></a>
+
+<blockquote><br>
+
+If this value is <em>true</em> (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.
+<p>
+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>
+
+<p><br>[Special variable]
+<br><a class=none name="*use-user-agent-for-sessions*"><b>*use-user-agent-for-sessions*</b></a>
+
+<blockquote><br> If this value is <em>true</em> (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.
+<p>
+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>
+
+<p><br>[Special variable]
+<br><a class=none name="*rewrite-for-session-urls*"><b>*rewrite-for-session-urls*</b></a>
+
+<blockquote><br> If this value is <em>true</em> (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>.
+<p>
+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>
+
+<p><br>[Special variable]
+<br><a class=none name="*content-types-for-url-rewrite*"><b>*content-types-for-url-rewrite*</b></a>
+
+<blockquote><br>
+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>
+
+<p><br>[Special variable]
+<br><a class=none name="*session-cookie-name*"><b>*session-cookie-name*</b></a>
+
+<blockquote><br>
+
+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>
+
+<p><br>[Special variable]
+<br><a class=none name="*session-removal-hook*"><b>*session-removal-hook*</b></a>
+
+<blockquote><br>
+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>
+
+<p><br>[Special variable]
+<br><a class=none name="*session-max-time*"><b>*session-max-time*</b></a>
+
+<blockquote><br>
+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>
+
+<p><br>[Macro]
+<br><a class=none name="do-sessions"><b>do-sessions</b> <i>(var</i> <tt>&optional</tt> <i>result-form) statement*</i> => <i>result</i></a>
+
+<blockquote><br>
+
+Executes the statements with <code><i>var</i></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><i>result-form</i></code> unless
+<code>RETURN</code> is executed. The scope of the binding of
+<code><i>var</i></code> does <em>not</em> include
+<code><i>result-form</i></code>.
+
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*session-gc-frequency*"><b>*session-gc-frequency*</b></a>
+
+<blockquote><br>
+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>
+
+<p><br>[Function]
+<br><a class=none name="session-gc"><b>session-gc</b> => |</a>
+
+<blockquote><br>
+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>
+
+<p><br>[Function]
+<br><a class=none name="session-too-old-p"><b>session-too-old-p</b> <i>session</i> => generalized-boolean</a>
+
+<blockquote><br> Returns a true value if the <code>SESSION</code>
+object <code><i>session</i></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.
+<p>
+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.
+
+<p><br>[Accessor]
+<br><a class=none name="log-file"><b>log-file</b> => <i>pathname</i>
+<br><tt>(setf (</tt><b>log-file</b>) <i>pathspec</i><tt>)</tt></a>
+
+<blockquote><br>
+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>
+
+<p><br>[Generic function]
+<br><a class=none name="log-message"><b>log-message</b> <i>log-level format</i> <tt>&rest</tt> <i>args</i> => |</a>
+
+<blockquote><br> 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><i>use-apache-log-p</i></code> argument
+to <a href="#start-server"><code>START-SERVER</code></a>. <code><i>log-level</i></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><i>log-level</i></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><i>format</i></code> and <code><i>args</i></code> are used as with
+<a href='http://www.lispworks.com/documentation/HyperSpec/Body/f_format.htm'><code>FORMAT</code></a>.
+<p>
+<code>LOG-MESSAGE</code> is a generic function, so you can specialize it or bypass it completely with an around method.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="log-message*"><b>log-message*</b> <i>format</i> <tt>&rest</tt> <i>args</i> => |</a>
+
+<blockquote><br>
+Like <a href="#log-message"><code>LOG-MESSAGE</code></a> but with <code><i>log-level</i></code> set to <a href="#*default-log-level*"><code>*DEFAULT-LOG-LEVEL*</code></a>.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*default-log-level*"><b>*default-log-level*</b></a>
+
+<blockquote><br>
+The log level used by <a href="#log-message*"><code>LOG-MESSAGE*</code></a>. The initial value is <code>NIL</code>.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*log-lisp-errors-p*"><b>*log-lisp-errors-p*</b></a>
+
+<blockquote><br>
+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>
+
+<p><br>[Special variable]
+<br><a class=none name="*lisp-errors-log-level*"><b>*lisp-errors-log-level*</b></a>
+
+<blockquote><br>
+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>
+
+<p><br>[Special variable]
+<br><a class=none name="*log-lisp-warnings-p*"><b>*log-lisp-warnings-p*</b></a>
+
+<blockquote><br>
+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>
+
+<p><br>[Special variable]
+<br><a class=none name="*lisp-warnings-log-level*"><b>*lisp-warnings-log-level*</b></a>
+
+<blockquote><br>
+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>
+
+<p><br>[Special variable]
+<br><a class=none name="*log-lisp-backtraces-p*"><b>*log-lisp-backtraces-p*</b></a>
+
+<blockquote><br>
+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 <em>true</em>. The default value is <code>NIL</code>.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*log-prefix*"><b>*log-prefix*</b></a>
+
+<blockquote><br>
+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>
+
+<p><br>[Special variable]
+<br><a class=none name="*show-lisp-errors-p*"><b>*show-lisp-errors-p*</b></a>
+
+<blockquote><br>
+Whether unhandled Lisp errors should be shown to the user. If this value is <code>NIL</code> (which is the default), only the message <em>An error has occurred</em> will be shown.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*show-lisp-backtraces-p*"><b>*show-lisp-backtraces-p*</b></a>
+
+<blockquote><br>
+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 <em>true</em>. The default value is <code>NIL</code>.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*show-access-log-messages*"><b>*show-access-log-messages*</b></a>
+
+<blockquote><br>
+If this variable is <em>true</em> <em>and</em> if the value of the <code><i>use-apache-log-p</i></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>
+
+<p><br>[Special variable]
+<br><a class=none
+name="*http-error-handler*"><b>*http-error-handler*</b></a>
+
+<blockquote><br>
+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>
+
+<p><br>[Special variable]
+<br><a class=none
+name="*handle-http-errors-p*"><b>*handle-http-errors-p*</b></a>
+
+<blockquote><br> 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>
+
+<p><br>[Special variable]
+<br><a class=none
+name="*approved-return-codes*"><b>*approved-return-codes*</b></a>
+<blockquote><br>
+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>
+
+<p><br>[Function]
+<br><a class=none name="get-backtrace"><b>get-backtrace</b> <i>condition</i> => <i>backtrace</i></a>
+
+<blockquote><br>
+This is the function that is used internally by Hunchentoot to
+show or log backtraces. It accepts a condition object <code><i>condition</i></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>.
+<p>
+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.
+<p>
+Good luck... :)
+
+<p><br>[Special variable]
+<br><a class=none name="*catch-errors-p*"><b>*catch-errors-p*</b></a>
+
+<blockquote><br> 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 <em>true</em> 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>
+
+<p><br>[Generic function]
+<br><a class=none name="maybe-invoke-debugger"><b>maybe-invoke-debugger</b> <i>condition</i> => |</a>
+
+<blockquote><br>
+This generic function is called whenever a
+<a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/09_.htm">condition</a> <code><i>condition</i></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><i>condition</i></code> if
+<a href="#*catch-errors-p*"><code>*CATCH-ERRORS-P*</code></a> is <code>NIL</code>.
+</blockquote>
+
+
+<p><br>[Special variable]
+<br><a class=none name="*header-stream*"><b>*header-stream*</b></a>
+
+<blockquote><br>
+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.
+
+<p><br>[Function]
+<br><a class=none name="ssl-p"><b>ssl-p</b> => generalized-boolean</a>
+
+<blockquote><br>
+Whether the current connection to the client is secure.
+</blockquote>
+
+<p><br>[Symbol]
+<br><a class=none name="handler-done"><b>handler-done</b></a>
+
+<blockquote><br> This is a <a
+href='http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#catch_tag'><em>catch
+tag</em></a> which names a <a
+href='http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#catch'><em>catch</em></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'><em>throw</em></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>
+
+<p><br>[Function]
+<br><a class=none name="no-cache"><b>no-cache</b> => |</a>
+
+<blockquote><br>
+This function will set appropriate outgoing headers to completely prevent caching on virtually all browsers.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="handle-if-modified-since"><b>handle-if-modified-since</b> <i>time</i> => |</a>
+
+<blockquote><br>
+
+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><i>time</i></code> then the header <a
+href="#+http-not-modified+"><code>+HTTP-NOT-MODIFIED+</code></a> with
+no content is immediately returned to the client.
+<p>
+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>
+
+<p><br>[Function]
+<br><a class=none name="rfc-1123-date"><b>rfc-1123-date</b> <tt>&optional</tt> <i>time</i> => <i>string</i></a>
+
+<blockquote><br>
+
+This function accepts a universal time <code><i>time</i></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>
+
+<p><br>[Function]
+<br><a class=none name="redirect"><b>redirect</b> <i>target</i> <tt>&key</tt> <i>host port protocol add-session-id permanently</i> => |</a>
+
+<blockquote><br> Sends back appropriate headers to redirect the client
+to <code><i>target</i></code> (a string).
+
+If <code><i>target</i></code> is a full URL starting with a scheme, <code><i>host</i></code>, <code><i>port</i></code>, and <code><i>protocol</i></code>
+are ignored. Otherwise, <code><i>target</i></code> should denote the path part of a
+URL, <code><i>protocol</i></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><i>host</i></code>, <code><i>port</i></code>, <code><i>protocol</i></code>,
+and <code><i>target</i></code>.
+<p>
+If <code><i>permanently</i></code>
+is <em>true</em> (the default is <code>NIL</code>), a 301 status
+code will be sent, otherwise a 302 status code. If <code><i>host</i></code>
+is not provided, the current host (see <a
+href="#host"><code>HOST</code></a>) will be
+used. If <code><i>protocol</i></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><i>host</i></code> and <code><i>protocol</i></code> aren't
+provided, then the value of <code><i>protocol</i></code> will
+match the current request.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="require-authorization"><b>require-authorization</b> <tt>&optional</tt> <i>realm</i> => |</a>
+
+<blockquote><br>
+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><i>realm</i></code>. The default value for <code><i>realm</i></code> is <code>"Hunchentoot"</code>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="escape-for-html"><b>escape-for-html</b> <i>string</i> => <i>escaped-string</i></a>
+
+<blockquote><br>
+Escapes all occurrences of the characters <code>#\<</code>, <code>#\></code>, <code>#\'</code>, <code>#"</code>, and <code>#\&</code> within <code><i>string</i></code> for HTML output.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="url-encode"><b>url-encode</b> <i>string</i> <tt>&optional</tt> <i>external-format</i> => <i>url-encoded-string</i></a>
+
+<blockquote><br>
+URL-encodes a string using the external format <code><i>external-format</i></code>. The default for <code><i>external-format</i></code> is the value of <a href="#*hunchentoot-default-external-format*"><code>*HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="url-decode"><b>url-decode</b> <i>string</i> <tt>&optional</tt> <i>external-format</i> => <i>url-encoded-string</i></a>
+
+<blockquote><br>
+URL-decodes a string using the external format <code><i>external-format</i></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><i>external-format</i></code> is the value of <a href="#*hunchentoot-default-external-format*"><code>*HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="http-token-p"><b>http-token-p</b> <i>object</i> => <i>generalized-boolean</i></a>
+
+<blockquote><br> This function tests
+whether <code><i>object</i></code> is a non-empty string which is
+a <em>token</em> 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>
+
+<p><br>[Special variable]
+<br><a class=none name="*tmp-directory*"><b>*tmp-directory*</b></a>
+
+<blockquote><br>
+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>
+
+<p><br>[Special variable]
+<br><a class=none
+name="*hunchentoot-default-external-format*"><b>*hunchentoot-default-external-format*</b></a>
+
+<blockquote><br> 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>
+
+<p><br>[Function]
+<br><a class=none name="mime-type"><b>mime-type</b> <i>pathspec</i> => <i>string</i></a>
+
+<blockquote><br>
+Given a pathname designator <code><i>pathspec</i></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><i>pathspec</i></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>
+
+<p><br>[Function]
+<br><a class=none name="reason-phrase"><b>reason-phrase</b> <i>return-code</i> => <i>string</i></a>
+
+<blockquote><br> Returns a reason phrase for the HTTP return
+code <code><i>return-code</i></code> (which should be an integer)
+or <code>NIL</code> for return codes Hunchentoot doesn't know.
+</blockquote>
+
+<br> <br><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.
+
+<br> <br><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 <em>Red Gorilla</em> that can't be quoted often enough (it
+seems the original source of the interview has vanished):
+
+<blockquote>
+<b>Q:</b> If you could go back and change anything, would <em>Red Gorilla</em> still be
+in business today?
+<p>
+<b>A:</b> Yes. I would start small and grow as the demand grew. That's what I'm
+doing now.
+<p>
+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.
+<p>
+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 <em>really</em> 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"><em>green</em>
+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 <em>really</em> 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>
+
+<br> <br><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").
+<p>
+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.
+<p>
+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>.
+<p>
+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 <em>almost</em> a full web server, so eventually I wrote
+Hunchentoot which <em>was</em> 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.
+<p>
+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.
+
+<br> <br><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>
+
+<br> <br><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>.
+<p>
+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.
+<p>
+Parts of this documentation were prepared
+with <a
+href="http://weitz.de/documentation-template/">DOCUMENTATION-TEMPLATE</a>, no animals were harmed.
+</p>
+<p>
+$Header: /usr/local/cvsrep/hunchentoot/doc/index.html,v 1.122 2007/11/15 07:29:58 edi Exp $
+<p><a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a>
+
+</body>
+</html>
Property changes on: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/doc/index.html
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/easy-handlers.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/easy-handlers.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/easy-handlers.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -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)))
Property changes on: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/easy-handlers.lisp
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/headers.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/headers.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/headers.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -0,0 +1,320 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/headers.lisp,v 1.24 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)
+
+(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<p><hr>~A</p></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
+ (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
Property changes on: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/headers.lisp
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/hunchentoot-test.asd
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/hunchentoot-test.asd 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/hunchentoot-test.asd 2007-11-15 07:42:51 UTC (rev 2282)
@@ -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))
Property changes on: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/hunchentoot-test.asd
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/hunchentoot.asd
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/hunchentoot.asd 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/hunchentoot.asd 2007-11-15 07:42:51 UTC (rev 2282)
@@ -0,0 +1,79 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/hunchentoot.asd,v 1.52 2007/11/15 07:29:56 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.14.7"
+ "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")
+ #+: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 :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")))
Property changes on: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/hunchentoot.asd
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/log.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/log.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/log.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -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.14.7/mime-types.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/mime-types.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/mime-types.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -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.14.7/misc.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/misc.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/misc.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -0,0 +1,274 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/misc.lisp,v 1.12 2007/11/15 07:29:56 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><p>This the Hunchentoot default page. You're most likely seeing it because the server administrator hasn't set up a custom default page yet.</p><p>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>.</p></p><p><hr>~A</p></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 '(unsigned-byte 8)
+ :if-does-not-exist nil)
+ (setf (header-out "Last-Modified") (rfc-1123-date time)
+ (content-length) (file-length file))
+ (let ((out (send-headers)))
+ (loop with buf = (make-array +buffer-length+ :element-type '(unsigned-byte 8))
+ 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))
Property changes on: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/misc.lisp
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/packages.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/packages.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/packages.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -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))
+
Property changes on: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/packages.lisp
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/port-acl.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/port-acl.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/port-acl.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -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.14.7/port-cmu.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/port-cmu.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/port-cmu.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -0,0 +1,137 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/port-cmu.lisp,v 1.9 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)
+
+#-: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 '(unsigned-byte 8)
+ :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.14.7/port-lw.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/port-lw.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/port-lw.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -0,0 +1,173 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/port-lw.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)
+
+#+(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.0 (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.0 #+:lispworks5.0
+ :write-timeout write-timeout
+ :element-type '(unsigned-byte 8))
+ (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)
+
Property changes on: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/port-lw.lisp
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/port-mcl.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/port-mcl.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/port-mcl.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -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.14.7/port-sbcl.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/port-sbcl.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/port-sbcl.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -0,0 +1,205 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/port-sbcl.lisp,v 1.12 2007/09/13 08:35:15 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 '(unsigned-byte 8)
+ :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.14.7/reply.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/reply.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/reply.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -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.14.7/request.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/request.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/request.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -0,0 +1,474 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/request.lisp,v 1.33 2007/09/14 12:12:33 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)))
+ (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.14.7/server.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/server.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/server.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -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)))))))
Property changes on: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/server.lisp
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/session.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/session.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/session.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -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.14.7/specials.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/specials.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/specials.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -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))))
Property changes on: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/specials.lisp
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/test/UTF-8-demo.html
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/test/UTF-8-demo.html 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/test/UTF-8-demo.html 2007-11-15 07:42:51 UTC (rev 2282)
@@ -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>
+ <p>Original by Markus Kuhn, adapted for HTML by Martin Dürst.</p>
+<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 £©µÀÆÖÞßéöÿ
+ –—‘“”„†•…‰™œŠŸž€ ΑΒΓΔΩαβγδω АБВГДабвгд
+ ∀∂∈ℝ∧∪≡∞ ↑↗↨↻⇣ ┐┼╔╘░►☺♀ fi�⑀₂ἠḂӥẄɐː⍎אԱა
+
+Greetings in various languages:
+
+ Hello world, Καλημέρα κόσμε, コンニチハ
+
+Box drawing alignment tests: █
+ ▉
+ ╔══╦══╗ ┌──┬──┐ ╭──┬──╮ ╭──┬──╮ ┏━━┳━━┓ ┎┒┏┑ ╷ ╻ ┏┯┓ ┌┰┐ ▊ ╱╲╱╲╳╳╳
+ ║┌─╨─┐║ │╔═╧═╗│ │╒═╪═╕│ │╓─╁─╖│ ┃┌─╂─┐┃ ┗╃╄┙ ╶┼╴╺╋╸┠┼┨ ┝╋┥ ▋ ╲╱╲╱╳╳╳
+ ║│╲ ╱│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╿ │┃ ┍╅╆┓ ╵ ╹ ┗┷┛ └┸┘ ▌ ╱╲╱╲╳╳╳
+ ╠╡ ╳ ╞╣ ├╢ ╟┤ ├┼─┼─┼┤ ├╫─╂─╫┤ ┣┿╾┼╼┿┫ ┕┛┖┚ ┌┄┄┐ ╎ ┏┅┅┓ ┋ ▍ ╲╱╲╱╳╳╳
+ ║│╱ ╲│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╽ │┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▎
+ ║└─╥─┘║ │╚═╤═╝│ │╘═╪═╛│ │╙─╀─╜│ ┃└─╂─┘┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▏
+ ╚══╩══╝ └──┴──┘ ╰──┴──╯ ╰──┴──╯ ┗━━┻━━┛ └╌╌┘ ╎ ┗╍╍┛ ┋ ▁▂▃▄▅▆▇█
+
+</pre>
+</body>
+</html>
Added: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/test/favicon.ico
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/test/favicon.ico
___________________________________________________________________
Name: svn:executable
+ *
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/test/fz.jpg
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/test/fz.jpg
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/test/packages.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/test/packages.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/test/packages.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -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
Property changes on: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/test/packages.lisp
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/test/test.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/test/test.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/test/test.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -0,0 +1,582 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/test/test.lisp,v 1.20 2007/09/18 14:24: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-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 '(unsigned-byte 8))
+ (let ((image-data (make-array (file-length in)
+ :element-type '(unsigned-byte 8))))
+ (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
+ (flexi-streams: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 '(unsigned-byte 8))))
+ (with-open-file (in *utf-8-file*
+ :element-type '(unsigned-byte 8))
+ (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 '(unsigned-byte 8))
+ (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 '(unsigned-byte 8))
+ (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.14.7/unix-acl.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/unix-acl.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/unix-acl.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -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.14.7/unix-cmu.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/unix-cmu.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/unix-cmu.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -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.14.7/unix-lw.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/unix-lw.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/unix-lw.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -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
Property changes on: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/unix-lw.lisp
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/unix-mcl.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/unix-mcl.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/unix-mcl.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -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.14.7/unix-sbcl.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/unix-sbcl.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/unix-sbcl.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -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.14.7/util.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/util.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/util.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -0,0 +1,406 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/util.lisp,v 1.32 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)
+
+#-: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 '(unsigned-byte 8)
+ :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))
Property changes on: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/util.lisp
___________________________________________________________________
Name: svn:executable
+ *
Modified: branches/trunk-reorg/thirdparty/slime/CVS/Entries
===================================================================
--- branches/trunk-reorg/thirdparty/slime/CVS/Entries 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/slime/CVS/Entries 2007-11-15 07:42:51 UTC (rev 2282)
@@ -1,34 +1,35 @@
-/.cvsignore/1.5/Sun Apr 8 19:23:57 2007//
-/ChangeLog/1.1234/Thu Sep 27 12:56:13 2007//
-/HACKING/1.8/Wed Sep 19 11:08:27 2007//
-/NEWS/1.8/Sun Mar 27 19:41:17 2005//
-/PROBLEMS/1.8/Sun Nov 20 23:31:56 2005//
-/README/1.14/Tue Oct 3 21:49:13 2006//
-/hyperspec.el/1.11/Thu Dec 7 07:36:54 2006//
-/metering.lisp/1.4/Fri Apr 1 20:16:35 2005//
-/mkdist.sh/1.7/Mon Aug 29 20:02:58 2005//
-/nregex.lisp/1.4/Mon Sep 19 08:20:48 2005//
-/sbcl-pprint-patch.lisp/1.1/Fri Feb 17 01:30:21 2006//
-/slime-autoloads.el/1.3/Thu Sep 20 14:59:08 2007//
-/slime.el/1.875/Thu Sep 27 12:56:40 2007//
-/swank-abcl.lisp/1.43/Tue Sep 4 15:45:19 2007//
-/swank-allegro.lisp/1.98/Wed Sep 26 23:15:41 2007//
-/swank-backend.lisp/1.126/Mon Sep 10 15:39:05 2007//
-/swank-clisp.lisp/1.64/Thu Aug 23 19:03:37 2007//
-/swank-cmucl.lisp/1.174/Wed Sep 5 12:04:43 2007//
-/swank-corman.lisp/1.11/Thu Aug 23 19:03:37 2007//
-/swank-ecl.lisp/1.8/Thu May 17 11:49:40 2007//
-/swank-gray.lisp/1.10/Wed Apr 12 08:43:55 2006//
-/swank-lispworks.lisp/1.92/Thu Aug 23 19:03:37 2007//
-/swank-loader.lisp/1.73/Fri Sep 14 12:41:28 2007//
-/swank-openmcl.lisp/1.119/Thu Aug 23 19:03:37 2007//
-/swank-sbcl.lisp/1.185/Tue Sep 11 19:31:03 2007//
-/swank-scl.lisp/1.13/Thu Aug 23 19:03:37 2007//
-/swank-source-file-cache.lisp/1.8/Tue Dec 5 13:00:42 2006//
-/swank-source-path-parser.lisp/1.17/Sun Jun 25 08:33:16 2006//
-/swank.asd/1.5/Fri Sep 14 12:41:28 2007//
-/swank.lisp/1.511/Wed Sep 19 11:12:07 2007//
-/test-all.sh/1.2/Mon Aug 29 20:02:58 2005//
-/test.sh/1.9/Mon Aug 27 13:16:49 2007//
-/xref.lisp/1.2/Mon May 17 00:25:24 2004//
-D
+D/contrib////
+D/doc////
+/.cvsignore/1.5/Thu Oct 11 14:10:25 2007//
+/ChangeLog/1.1241/Wed Nov 14 21:30:35 2007//
+/HACKING/1.8/Thu Oct 11 14:10:25 2007//
+/NEWS/1.8/Thu Oct 11 14:10:25 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.3/Thu Oct 11 14:10:25 2007//
+/slime.el/1.877/Wed Nov 14 21:30:35 2007//
+/swank-abcl.lisp/1.44/Wed Nov 14 21:30:35 2007//
+/swank-allegro.lisp/1.98/Thu Oct 11 14:10:25 2007//
+/swank-backend.lisp/1.126/Thu Oct 11 14:10:25 2007//
+/swank-clisp.lisp/1.64/Thu Oct 11 14:10:25 2007//
+/swank-cmucl.lisp/1.174/Thu Oct 11 14:10:25 2007//
+/swank-corman.lisp/1.11/Thu Oct 11 14:10:25 2007//
+/swank-ecl.lisp/1.8/Thu Oct 11 14:10:25 2007//
+/swank-gray.lisp/1.10/Thu Oct 11 14:10:25 2007//
+/swank-lispworks.lisp/1.92/Thu Oct 11 14:10:25 2007//
+/swank-loader.lisp/1.74/Wed Nov 14 21:30:35 2007//
+/swank-openmcl.lisp/1.120/Wed Nov 14 21:30:35 2007//
+/swank-sbcl.lisp/1.185/Thu Oct 11 14:10:25 2007//
+/swank-scl.lisp/1.13/Thu Oct 11 14:10:25 2007//
+/swank-source-file-cache.lisp/1.8/Thu Oct 11 14:10:25 2007//
+/swank-source-path-parser.lisp/1.17/Thu Oct 11 14:10:25 2007//
+/swank.asd/1.5/Thu Oct 11 14:10:25 2007//
+/swank.lisp/1.513/Wed Nov 14 21:30:35 2007//
+/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 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/slime/ChangeLog 2007-11-15 07:42:51 UTC (rev 2282)
@@ -1,3 +1,67 @@
+2007-11-06 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-events-buffer, slime-inspector-buffer): Disable
+ undo.
+
+2007-11-01 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ The inspector page layout has changed slightly. Before the header
+ looked like
+
+ A proper list.
+ [type: CONS]
+ -------------------
+
+ It now looks like
+
+ #<CONS {B3DBD39}>:
+ A proper list.
+ --------------------
+
+ Rationale is to have a "presentation link" to the currently
+ inspected object itself, to copy it down to the REPL via `M-RET'.
+ This is mostly useful when trying to get a value from the Slime
+ Debugger to the REPL, which you can do by inspecting the value
+ first by `i', and then using `M-RET' on the object representation
+ in the new header layout.
+
+ Such a "presentation link" existed already but was removed in
+ 2007-08-23. The old behaviour was to have the title ("A proper
+ list" in the above example) to contain the link. I decided to make
+ the link more explicit.
+
+ * swank.lisp (inspect-object): Now additionally returns a
+ string-representation of the object itself, and an inspector id
+ for it. Removed returning its type as this is implicit in the new
+ string representation.
+
+ * slime.el (slime-open-inspector): Adapted for new header layout.
+
+2007-10-22 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank.lisp (read-softly-from-string, unintern-in-home-package):
+ Moved from `contrib/swank-arglist.lisp'.
+ (parse-package): Use them. (Removes FIXME about interning
+ symbols.) Also changed the logic somewhat to avoid passing :|| to
+ FIND-PACKAGE as ECL chokes on that.
+
+2007-10-22 Steve Smith <tarkasteve(a)gmail.com>
+
+ * swank-loader.lisp (compile-files-if-needed-serially): Added
+ missing `load' argument to function definition on Corman Lisp /
+ ECL.
+
+2007-10-22 Mark Evenson <mark.evenson(a)gmx.at>
+
+ * swank-abcl.lisp (getpid): Implemented.
+
+2007-10-22 R. Matthew Emerson <rme(a)thoughtstuff.com>
+
+ * swank-openmcl.lisp (closure-closed-over-values): Use
+ CCL::NTH-IMMEDIATE instead of CCL::%SVREF. This makes it work on
+ x86-64 OpenMCL. (The %SVREF worked on PPC, but this will work on
+ both.)
+
2007-09-27 Tobias C. Rittweiler <tcr(a)freebits.de>
* slime.el (slime-filesystem-toplevel-directory): New function.
Modified: branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries
===================================================================
--- branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries 2007-11-15 07:42:51 UTC (rev 2282)
@@ -1,30 +1,30 @@
-/ChangeLog/1.62/Mon Oct 1 13:37:22 2007//
-/README/1.3/Fri Sep 28 13:05:44 2007//
-/bridge.el/1.1/Wed Sep 19 11:47:03 2007//
-/inferior-slime.el/1.2/Mon Sep 10 21:44:48 2007//
-/slime-asdf.el/1.3/Fri Sep 21 12:44:13 2007//
-/slime-autodoc.el/1.5/Mon Oct 1 13:37:10 2007//
-/slime-banner.el/1.4/Thu Sep 20 14:55:53 2007//
-/slime-c-p-c.el/1.8/Thu Sep 20 14:55:53 2007//
-/slime-editing-commands.el/1.5/Thu Sep 20 14:55:53 2007//
-/slime-fancy-inspector.el/1.2/Thu Sep 20 14:55:53 2007//
-/slime-fancy.el/1.4/Fri Sep 28 13:05:35 2007//
-/slime-fuzzy.el/1.4/Thu Sep 20 14:55:53 2007//
-/slime-highlight-edits.el/1.3/Thu Sep 20 14:55:53 2007//
-/slime-parse.el/1.7/Sat Sep 15 11:09:36 2007//
-/slime-presentation-streams.el/1.2/Tue Aug 28 08:25:12 2007//
-/slime-presentations.el/1.8/Thu Sep 20 14:55:53 2007//
-/slime-references.el/1.4/Thu Sep 20 14:55:53 2007//
-/slime-scratch.el/1.4/Thu Sep 20 14:55:53 2007//
-/slime-tramp.el/1.2/Tue Sep 4 10:18:44 2007//
-/slime-typeout-frame.el/1.5/Mon Oct 1 11:50:06 2007//
-/slime-xref-browser.el/1.1/Fri Aug 24 14:47:11 2007//
-/swank-arglists.lisp/1.10/Tue Sep 11 12:33:00 2007//
-/swank-asdf.lisp/1.1/Tue Sep 4 10:32:07 2007//
-/swank-c-p-c.lisp/1.2/Wed Sep 5 19:35:35 2007//
-/swank-fancy-inspector.lisp/1.4/Thu Sep 20 14:55:53 2007//
-/swank-fuzzy.lisp/1.6/Sat Sep 15 22:21:21 2007//
-/swank-listener-hooks.lisp/1.1/Tue Aug 28 13:53:02 2007//
-/swank-presentation-streams.lisp/1.4/Tue Aug 28 16:26:32 2007//
-/swank-presentations.lisp/1.4/Tue Sep 4 09:49:10 2007//
+/ChangeLog/1.64/Wed Nov 14 21:30:35 2007//
+/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.5/Thu Oct 11 14:10:25 2007//
+/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.5/Thu Oct 11 14:10:25 2007//
+/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.4/Thu Oct 11 14:10:25 2007//
+/slime-highlight-edits.el/1.3/Thu Oct 11 14:10:25 2007//
+/slime-parse.el/1.7/Thu Oct 11 14:10:25 2007//
+/slime-presentation-streams.el/1.2/Thu Oct 11 14:10:25 2007//
+/slime-presentations.el/1.8/Thu Oct 11 14:10:25 2007//
+/slime-references.el/1.4/Thu Oct 11 14:10:25 2007//
+/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.5/Thu Oct 11 14:10:25 2007//
+/slime-xref-browser.el/1.1/Thu Oct 11 14:10:25 2007//
+/swank-arglists.lisp/1.12/Wed Nov 14 21:30:35 2007//
+/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.4/Thu Oct 11 14:10:25 2007//
+/swank-fuzzy.lisp/1.6/Thu Oct 11 14:10:25 2007//
+/swank-listener-hooks.lisp/1.1/Thu Oct 11 14:10:25 2007//
+/swank-presentation-streams.lisp/1.4/Thu Oct 11 14:10:25 2007//
+/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 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog 2007-11-15 07:42:51 UTC (rev 2282)
@@ -1,3 +1,15 @@
+2007-10-24 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank-arglist.lisp (decode-arglist): Fix incompatibility with
+ ACL's modern reader mode. Thanks to Andreas Fuchs for stumbling
+ over this.
+
+2007-10-22 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank-arglist.lisp (read-softly): Renamed to
+ READ-SOFTLY-FROM-STRING and moved to `swank.lisp'.
+ (unintern-in-home-package): Moved to `swank.lisp'.
+
2007-10-01 Tobias C. Rittweiler <tcr(a)freebits.de>
* slime-autdoc.el (slime-autodoc-message-ok-p): Don't display an
Modified: branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -199,8 +199,8 @@
the returned datum is a symbol and has been newly interned in
some package.
-If READER is not explicitly given, the function READ-SOFTLY is
-used instead."
+If READER is not explicitly given, the function
+READ-SOFTLY-FROM-STRING* is used instead."
(when spec
(with-buffer-syntax ()
(call-with-ignored-reader-errors
@@ -211,13 +211,13 @@
(etypecase element
(string
(multiple-value-bind (sexp newly-interned?)
- (funcall (or reader 'read-softly) element)
+ (funcall (or reader 'read-softly-from-string*) element)
(push sexp result)
(when newly-interned?
(push sexp newly-interned-symbols))))
(cons
(multiple-value-bind (read-spec interned-symbols)
- (read-form-spec element)
+ (read-form-spec element reader)
(push read-spec result)
(setf newly-interned-symbols
(append interned-symbols
@@ -227,29 +227,15 @@
(values (nreverse result)
(nreverse newly-interned-symbols))))))))
-(defun unintern-in-home-package (symbol)
- (unintern symbol (symbol-package symbol)))
+(defun read-softly-from-string* (string)
+ "Like READ-SOFTLY-FROM-STRING, but only returns the sexp and
+the flag if a symbol had to be interned."
+ (multiple-value-bind (sexp pos interned?)
+ (read-softly-from-string string)
+ (declare (ignore pos))
+ (values sexp interned?)))
-(defun read-softly (string)
- "Returns two values:
- 1. the object resulting from READing STRING.
-
- 2. 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 nil)
- (let ((sexp (read-from-string string)))
- (values sexp
- (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)))))))))))
-
-
(defstruct (arglist (:conc-name arglist.) (:predicate arglist-p))
provided-args ; list of the provided actual arguments
required-args ; list of the required arguments
@@ -541,7 +527,7 @@
(setq mode arg)
(push arg (arglist.known-junk result)))
((and (symbolp arg)
- (string= (symbol-name arg) (string '#:&ANY))) ; may be interned
+ (string= (symbol-name arg) (string '#:&any))) ; may be interned
(setf (arglist.any-p result) t) ; in any *package*.
(setq mode '&any))
((member arg lambda-list-keywords)
Modified: branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries
===================================================================
--- branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries 2007-11-15 07:42:51 UTC (rev 2282)
@@ -1,9 +1,9 @@
-/.cvsignore/1.1/Mon Jul 24 14:13:23 2006//
-/Makefile/1.12/Mon Sep 17 14:04:27 2007//
-/slime-refcard.pdf/1.1/Thu Aug 9 09:18:50 2007//
-/slime-refcard.tex/1.1/Thu Aug 9 09:18:50 2007//
-/slime-small.eps/1.1/Wed Nov 22 06:27:38 2006//
-/slime-small.pdf/1.1/Wed Nov 22 06:27:38 2006//
-/slime.texi/1.57/Mon Sep 17 13:44:48 2007//
-/texinfo-tabulate.awk/1.2/Mon Aug 29 20:02:57 2005//
+/.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.57/Thu Oct 11 14:10:24 2007//
+/texinfo-tabulate.awk/1.2/Thu Oct 11 14:10:24 2007//
D
Modified: branches/trunk-reorg/thirdparty/slime/slime.el
===================================================================
--- branches/trunk-reorg/thirdparty/slime/slime.el 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/slime/slime.el 2007-11-15 07:42:51 UTC (rev 2282)
@@ -2486,6 +2486,7 @@
(or (get-buffer slime-event-buffer-name)
(let ((buffer (get-buffer-create slime-event-buffer-name)))
(with-current-buffer buffer
+ (buffer-disable-undo)
(set (make-local-variable 'outline-regexp) "^(")
(set (make-local-variable 'comment-start) ";")
(set (make-local-variable 'comment-end) "")
@@ -7470,6 +7471,7 @@
(or (get-buffer "*Slime Inspector*")
(with-current-buffer (get-buffer-create "*Slime Inspector*")
(setq slime-inspector-mark-stack '())
+ (buffer-disable-undo)
(slime-mode t)
(slime-inspector-mode)
(make-local-variable 'slime-saved-window-config)
@@ -7486,14 +7488,19 @@
(setq slime-buffer-connection (slime-current-connection))
(let ((inhibit-read-only t))
(erase-buffer)
- (destructuring-bind (&key title type content) inspected-parts
+ (destructuring-bind (&key string-representation id title content) inspected-parts
(macrolet ((fontify (face string)
`(slime-inspector-fontify ,face ,string)))
+ (slime-propertize-region
+ (list 'slime-part-number id
+ 'mouse-face 'highlight
+ 'face 'slime-inspector-value-face)
+ (insert string-representation))
+ (insert ":\n ")
(insert (fontify topline title))
(while (eq (char-before) ?\n)
(backward-delete-char 1))
- (insert "\n [" (fontify label "type:") " " (fontify type type) "]\n"
- (fontify label "--------------------") "\n")
+ (insert "\n" (fontify label "--------------------") "\n")
(save-excursion
(mapc #'slime-inspector-insert-ispec content))
(pop-to-buffer (current-buffer))
Modified: branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -142,9 +142,39 @@
(defimplementation call-without-interrupts (fn)
(funcall fn))
-;;there are too many to count
(defimplementation getpid ()
- 0)
+ (if (not (find :unix *features*))
+ 0
+ (let* ((runtime
+ (java:jstatic "getRuntime" "java.lang.Runtime"))
+ (command
+ (java:jnew-array-from-array
+ "java.lang.String" #("sh" "-c" "echo $PPID")))
+ (runtime-exec-jmethod
+ ;; Complicated because java.lang.Runtime.exec() is
+ ;; overloaded on a non-primitive type (array of
+ ;; java.lang.String), so we have to use the actual parameter
+ ;; instance to get java.lang.Class
+ (java:jmethod "java.lang.Runtime" "exec"
+ (java:jcall
+ (java:jmethod "java.lang.Object" "getClass")
+ command)))
+ (process
+ (java:jcall runtime-exec-jmethod runtime command))
+ (output
+ (java:jcall (java:jmethod "java.lang.Process" "getInputStream")
+ process)))
+ (java:jcall (java:jmethod "java.lang.Process" "waitFor") process)
+ (loop
+ :with b
+ :do (setq b
+ (java:jcall (java:jmethod "java.io.InputStream" "read")
+ output))
+ :until (member b '(-1 #x0a)) ; Either EOF or LF
+ :collecting (code-char b) :into result
+ :finally (return
+ (values
+ (parse-integer (coerce result 'string))))))))
(defimplementation lisp-implementation-type-name ()
"armedbear")
Modified: branches/trunk-reorg/thirdparty/slime/swank-loader.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-loader.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/slime/swank-loader.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -166,12 +166,13 @@
(handle-loadtime-error c binary-pathname)))))))
#+(or cormanlisp ecl)
-(defun compile-files-if-needed-serially (files fasl-directory)
+(defun compile-files-if-needed-serially (files fasl-directory load)
"Corman Lisp and ECL have trouble with compiled files."
(declare (ignore fasl-directory))
- (dolist (file files)
- (load file :verbose t)
- (force-output)))
+ (when load
+ (dolist (file files)
+ (load file :verbose t)
+ (force-output))))
(defun load-user-init-file ()
"Load the user init file, return NIL if it does not exist."
Modified: branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -849,7 +849,7 @@
(let ((howmany (nth-value 8 (ccl::function-args (ccl::closure-function closure)))))
(loop for n below howmany
collect
- (let* ((value (ccl::%svref closure (+ 1 (- howmany n))))
+ (let* ((value (ccl::nth-immediate closure (+ 1 (- howmany n))))
(map (car (ccl::function-symbol-map (ccl::closure-function closure))))
(label (or (and map (svref map n)) n))
(cellp (ccl::closed-over-value-p value)))
Modified: branches/trunk-reorg/thirdparty/slime/swank.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/slime/swank.lisp 2007-11-14 15:28:13 UTC (rev 2281)
+++ branches/trunk-reorg/thirdparty/slime/swank.lisp 2007-11-15 07:42:51 UTC (rev 2282)
@@ -1517,6 +1517,30 @@
(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 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
@@ -1602,20 +1626,23 @@
(values symbol status)
(error "Unknown symbol: ~A [in ~A]" string package))))
-;; FIXME: interns the name
(defun parse-package (string)
"Find the package named STRING.
Return the package or nil."
- (multiple-value-bind (name pos)
- (if (zerop (length string))
- (values :|| 0)
+ (check-type string (or string null))
+ (if (zerop (length string))
+ nil
+ (multiple-value-bind (name pos interned?)
(let ((*package* *swank-io-package*))
- (ignore-errors (read-from-string string))))
- (and name
- (or (symbolp name)
- (stringp name))
- (= (length string) pos)
- (find-package name))))
+ (ignore-errors (read-softly-from-string string)))
+ (unwind-protect
+ (and name
+ (or (symbolp name)
+ (stringp name))
+ (= (length string) pos)
+ (find-package name))
+ (when interned?
+ (unintern-in-home-package name))))))
(defun unparse-name (string)
"Print the name STRING according to the current printer settings."
@@ -2907,7 +2934,10 @@
(*print-readably* nil))
(multiple-value-bind (title content) (inspect-for-emacs object inspector)
(list :title title
- :type (to-string (type-of object))
+ :string-representation
+ (with-output-to-string (stream)
+ (print-unreadable-object (object stream :type t :identity t)))
+ :id (assign-index object *inspectee-parts*)
:content (inspector-content-for-emacs content)))))
(defslimefun inspector-nth-part (index)
1
0
14 Nov '07
Author: hhubner
Date: 2007-11-14 10:28:13 -0500 (Wed, 14 Nov 2007)
New Revision: 2281
Modified:
branches/trunk-reorg/bknr/datastore/src/data/txn.lisp
Log:
Revive accidentially removed lines.
Modified: branches/trunk-reorg/bknr/datastore/src/data/txn.lisp
===================================================================
--- branches/trunk-reorg/bknr/datastore/src/data/txn.lisp 2007-11-14 07:35:39 UTC (rev 2280)
+++ branches/trunk-reorg/bknr/datastore/src/data/txn.lisp 2007-11-14 15:28:13 UTC (rev 2281)
@@ -137,14 +137,16 @@
(with-open-file (f (store-random-state-pathname store))
(format t "reading store random state~%")
(setf (store-random-state store) (read f)))
- (with-open-file (f (store-random-state-pathname store) :direction :output :if-does-not-exist :create)
+ (with-open-file (f (store-random-state-pathname store)
+ :direction :output :if-does-not-exist :create :if-exists :supersede)
(format t "initializing store random state~%")
(with-standard-io-syntax
(prin1 (setf (store-random-state store) (make-random-state t)) f)))))
(defmethod update-store-random-state ((store store))
(format t "saving store random state~%")
- (with-open-file (f (store-random-state-pathname store) :direction :output :if-does-not-exist :create)
+ (with-open-file (f (store-random-state-pathname store)
+ :direction :output :if-does-not-exist :create :if-exists :supersede)
(with-standard-io-syntax
(prin1 (store-random-state store) f))))
@@ -478,10 +480,11 @@
(format *trace-output* "Snapshotting subsystem ~A of ~A~%" subsystem store))
(snapshot-subsystem store subsystem)
(when *store-debug*
- (format *trace-output* "Successfully snapshotted ~A of ~A~%" subsystem store))))
+ (format *trace-output* "Successfully snapshotted ~A of ~A~%" subsystem store)))
+ (setf (store-transaction-run-time store) 0)
+ (setf error nil))
(when error
- (warn "Restoring backup ~A to current."
- backup-directory)
+ (warn "Restoring backup ~A to current." backup-directory)
(rename-file backup-directory (store-current-directory store))))))))))
(defvar *show-transactions* nil)
1
0
14 Nov '07
Author: hhubner
Date: 2007-11-14 02:35:39 -0500 (Wed, 14 Nov 2007)
New Revision: 2280
Modified:
branches/trunk-reorg/projects/scrabble/src/start-webserver.lisp
Log:
Remove hunchentoot patch.
Modified: branches/trunk-reorg/projects/scrabble/src/start-webserver.lisp
===================================================================
--- branches/trunk-reorg/projects/scrabble/src/start-webserver.lisp 2007-11-14 07:31:01 UTC (rev 2279)
+++ branches/trunk-reorg/projects/scrabble/src/start-webserver.lisp 2007-11-14 07:35:39 UTC (rev 2280)
@@ -20,45 +20,6 @@
(make-pathname :name nil :type nil :version nil
:defaults (merge-pathnames #p"../../../thirdparty/MochiKit/MochiKit/" *load-truename*)))
-
-;; for now...
-(in-package :hunchentoot)
-
-(defun enough-url (url url-prefix)
- (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)))
-
-(in-package :scrabble.web)
-
(defun start-webserver (&key (port 4242))
(open-scrabble-store)
(when (and (boundp '*server*) *server*)
1
0
14 Nov '07
Author: hhubner
Date: 2007-11-14 02:31:01 -0500 (Wed, 14 Nov 2007)
New Revision: 2279
Modified:
branches/trunk-reorg/thirdparty/hunchentoot-0.14.6/misc.lisp
Log:
Fix for OpenMCL, ENOUGH-NAMESTRING should be used only for path names,
not URIs.
Modified: branches/trunk-reorg/thirdparty/hunchentoot-0.14.6/misc.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.6/misc.lisp 2007-11-14 07:13:33 UTC (rev 2278)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.6/misc.lisp 2007-11-14 07:31:01 UTC (rev 2279)
@@ -177,6 +177,9 @@
(lambda ()
(handle-static-file path content-type)))))
+(defun enough-url (url url-prefix)
+ (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
@@ -193,8 +196,8 @@
(error "~S is supposed to denote a directory." base-path))
(flet ((handler ()
(let* ((script-name (url-decode (script-name)))
- (script-path (enough-namestring (regex-replace-all "\\\\" script-name "/")
- uri-prefix))
+ (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)
1
0
14 Nov '07
Author: hhubner
Date: 2007-11-14 02:13:33 -0500 (Wed, 14 Nov 2007)
New Revision: 2278
Modified:
branches/trunk-reorg/bknr/datastore/src/data/txn.lisp
Log:
Add :SHARING :LOCK to transaction log stream open args so that it can
be used by multiple threads.
Modified: branches/trunk-reorg/bknr/datastore/src/data/txn.lisp
===================================================================
--- branches/trunk-reorg/bknr/datastore/src/data/txn.lisp 2007-11-14 07:00:51 UTC (rev 2277)
+++ branches/trunk-reorg/bknr/datastore/src/data/txn.lisp 2007-11-14 07:13:33 UTC (rev 2278)
@@ -177,7 +177,8 @@
:element-type '(unsigned-byte 8)
:direction :output
:if-does-not-exist :create
- :if-exists :append)))))
+ :if-exists :append
+ #+openmcl :sharing #+openmcl :lock)))))
(defmethod close-transaction-log-stream ((store store))
(with-slots (transaction-log-stream) store
1
0