[claw-cvs] r1 - in trunk: . doc doc/blender doc/chapters logo main main/claw-core main/claw-core/src main/claw-core/tests
achiumenti at common-lisp.net
achiumenti at common-lisp.net
Tue Jan 22 06:44:14 UTC 2008
Author: achiumenti
Date: Tue Jan 22 01:44:06 2008
New Revision: 1
Added:
trunk/
trunk/doc/
trunk/doc/CREDITS
trunk/doc/Makefile
trunk/doc/README
trunk/doc/blender/
trunk/doc/chapters/
trunk/doc/claw.texinfo
trunk/doc/figure1.png (contents, props changed)
trunk/logo/
trunk/logo/claw.svg
trunk/main/
trunk/main/claw-core/
trunk/main/claw-core/claw-tests.asd
trunk/main/claw-core/claw.asd
trunk/main/claw-core/src/
trunk/main/claw-core/src/components.lisp
trunk/main/claw-core/src/hunchentoot-overrides.lisp
trunk/main/claw-core/src/lisplet.lisp
trunk/main/claw-core/src/misc.lisp
trunk/main/claw-core/src/packages.lisp
trunk/main/claw-core/src/server.lisp
trunk/main/claw-core/src/tags.lisp
trunk/main/claw-core/tests/
trunk/main/claw-core/tests/packages.lisp
trunk/main/claw-core/tests/test1.lisp
Log:
first commit
Added: trunk/doc/CREDITS
==============================================================================
Added: trunk/doc/Makefile
==============================================================================
--- (empty file)
+++ trunk/doc/Makefile Tue Jan 22 01:44:06 2008
@@ -0,0 +1,22 @@
+DOCFILES:=*.texinfo
+MAINFILE=claw
+I_FLAGS=-I chapters/
+TEXI2PDF=texi2pdf
+MAKEINFO=makeinfo
+DIRNAME=`dirname`
+MYPNGS=$(wildcard *.png)
+MYPDFS=$(MYPNGS:%.png=%.pdf)
+
+all: $(MYPDFS) html pdf
+
+$(MYPDFS) : %.pdf : %.png
+ convert $< $@
+
+html:
+ ${MAKEINFO} --html ${MAINFILE}.texinfo
+
+pdf:
+ ${TEXI2PDF} ${I_FLAGS} --output=${MAINFILE}.pdf ${MAINFILE}.texinfo
+
+clean:
+ rm -rf ${MAINFILE} *.pdf *.ps
Added: trunk/doc/README
==============================================================================
Added: trunk/doc/claw.texinfo
==============================================================================
--- (empty file)
+++ trunk/doc/claw.texinfo Tue Jan 22 01:44:06 2008
@@ -0,0 +1,67 @@
+\input texinfo @c -*-texinfo-*-
+
+ at c %**start of header
+ at setfilename claw.info
+ at settitle CLAW User Manual
+ at c %**end of header
+
+ at set claw CLAW
+ at set VERSION 0.1
+ at set UPDATE-MONTH genuary 2008
+ at settitle @value{claw} @value{VERSION} User Manual
+
+ at copying
+ at quotation
+This manual is part of the @value{claw} software system. See the
+ at file{README} file for more information.
+
+This manual is in the public domain and is
+provided with absolutely no warranty. See the @file{COPYING} and
+ at file{CREDITS} files for more information.
+ at end quotation
+ at end copying
+
+ at titlepage
+ at title @value{claw} User Manual
+ at subtitle @value{claw} version @value{VERSION}
+ at subtitle @value{UPDATE-MONTH}
+
+ at c The following two commands start the copyright page.
+ at page
+ at vskip 0pt plus 1filll
+ at insertcopying
+
+ at end titlepage
+
+ at contents
+
+ at ifnottex
+
+ at node Top
+ at comment node-name, next, previous, up
+ at top About this manual
+
+ at insertcopying
+
+ at menu
+* Introduction::
+* Server::
+* Function index::
+ at c * Starting and Stopping::
+ at c * Compiler::
+ at c * Debugger::
+ at c * Efficiency::
+ at c * Beyond the ANSI Standard::
+ at c * Type Index::
+ at end menu
+
+ at end ifnottex
+
+ at include chapters/intro.texinfo
+ at include chapters/server.texinfo
+
+ at node Function index
+ at unnumbered Function index
+ at printindex fn
+
+ at bye
Added: trunk/doc/figure1.png
==============================================================================
Binary file. No diff available.
Added: trunk/logo/claw.svg
==============================================================================
--- (empty file)
+++ trunk/logo/claw.svg Tue Jan 22 01:44:06 2008
@@ -0,0 +1,89 @@
+<?xml version="1.0" encoding="UTF-8" standalone="no"?>
+<!-- Created with Inkscape (http://www.inkscape.org/) -->
+<svg
+ xmlns:dc="http://purl.org/dc/elements/1.1/"
+ xmlns:cc="http://web.resource.org/cc/"
+ xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+ xmlns:svg="http://www.w3.org/2000/svg"
+ xmlns="http://www.w3.org/2000/svg"
+ xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"
+ xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"
+ width="395.3533"
+ height="452.69388"
+ id="svg2"
+ sodipodi:version="0.32"
+ inkscape:version="0.45.1"
+ sodipodi:docbase="/home/kiuma/lispWks/cl-webobjects"
+ sodipodi:docname="claw.svg"
+ inkscape:output_extension="org.inkscape.output.svg.inkscape"
+ version="1.0">
+ <defs
+ id="defs4" />
+ <sodipodi:namedview
+ id="base"
+ pagecolor="#ffffff"
+ bordercolor="#666666"
+ borderopacity="1.0"
+ inkscape:pageopacity="0.0"
+ inkscape:pageshadow="2"
+ inkscape:zoom="0.49497475"
+ inkscape:cx="-221.21661"
+ inkscape:cy="243.96822"
+ inkscape:document-units="px"
+ inkscape:current-layer="g2186"
+ inkscape:window-width="844"
+ inkscape:window-height="596"
+ inkscape:window-x="535"
+ inkscape:window-y="240" />
+ <metadata
+ id="metadata7">
+ <rdf:RDF>
+ <cc:Work
+ rdf:about="">
+ <dc:format>image/svg+xml</dc:format>
+ <dc:type
+ rdf:resource="http://purl.org/dc/dcmitype/StillImage" />
+ </cc:Work>
+ </rdf:RDF>
+ </metadata>
+ <g
+ inkscape:label="Livello 1"
+ inkscape:groupmode="layer"
+ id="layer1"
+ transform="translate(-1.5750449e-6,-599.66831)">
+ <g
+ id="g2186"
+ transform="translate(-182.7324,243.63533)">
+ <path
+ sodipodi:nodetypes="czczcsc"
+ id="path2184"
+ d="M 574.28571,712.93361 C 574.28571,712.93361 497.0762,864.36966 322.85714,778.64789 C 147.49119,692.36181 191.42857,404.36218 191.42857,404.36218 C 191.42857,404.36218 249.28571,430.07647 298.57143,430.07647 C 347.85714,430.07647 388.57143,404.36218 388.57143,404.36218 C 388.57143,404.36218 301.42527,582.9303 378.57143,660.07646 C 447.17633,728.68136 574.28571,712.93361 574.28571,712.93361 z "
+ style="fill:#d9b134;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:7.5999999;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" />
+ <path
+ style="fill:#ffff85;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:7.5999999;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ d="M 574.28571,712.93361 C 574.28571,712.93361 468.79193,795.67929 367.30385,740.26209 C 265.08098,684.44367 281.83722,437.69722 281.83722,437.69722 C 281.83722,437.69722 298.73168,448.20074 343.01814,429.57139 C 386.24294,411.38865 388.57143,404.36218 388.57143,404.36218 C 388.57143,404.36218 301.42527,582.9303 378.57143,660.07646 C 447.17633,728.68136 574.28571,712.93361 574.28571,712.93361 z "
+ id="path2170"
+ sodipodi:nodetypes="czczcsc" />
+ <path
+ style="fill:#ffcc16;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.9;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ d="M 574.28571,712.93361 C 574.28571,712.93361 493.03559,799.7199 373.36477,748.34331 C 256.12816,698.01178 268.07761,436.21788 268.07761,436.21788 C 268.07761,436.21788 260.5593,443.54704 303.57143,435.79076 C 347.14285,427.93361 388.57143,404.36218 388.57143,404.36218 C 388.57143,404.36218 284.28241,605.78744 361.42857,682.9336 C 430.03347,751.5385 574.28571,712.93361 574.28571,712.93361 z "
+ id="path2214"
+ sodipodi:nodetypes="czczcsc" />
+ <path
+ sodipodi:nodetypes="cssscscsssc"
+ id="path2186"
+ d="M 568.60778,714.63119 C 568.60778,714.63119 555.15172,738.78869 513.68644,760.07049 C 475.21405,779.81621 438.21293,772.86104 405.69624,766.07942 C 343.66906,753.14314 300.82929,717.20788 276.50661,675.32185 C 263.76746,653.38378 237.59798,608.21343 241.16941,438.21344 C 241.16941,438.21344 245.86186,440.51972 265.40978,440.02636 C 286.10384,439.50406 294.2798,435.89726 294.2798,435.89726 C 275.32828,566.97873 287.34798,625.24753 314.44785,674.20916 C 337.22107,715.35379 384.60573,742.83441 441.41324,751.96937 C 469.45232,756.47821 488.72704,758.51616 518.0041,748.36048 C 538.09485,741.39137 568.60778,714.63119 568.60778,714.63119 z "
+ style="fill:#ffff85;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.92731011px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" />
+ <path
+ transform="matrix(0.9197522,-8.7906129e-2,0.101145,0.998963,-23.194129,22.377644)"
+ d="M 410.00002 402.36218 A 111.42857 37.142857 0 1 1 187.14287,402.36218 A 111.42857 37.142857 0 1 1 410.00002 402.36218 z"
+ sodipodi:ry="37.142857"
+ sodipodi:rx="111.42857"
+ sodipodi:cy="402.36218"
+ sodipodi:cx="298.57144"
+ id="path3161"
+ style="fill:#a16226;fill-opacity:1;fill-rule:nonzero;stroke:#000000;stroke-width:7.5999999;stroke-linecap:butt;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ sodipodi:type="arc" />
+ </g>
+ </g>
+</svg>
Added: trunk/main/claw-core/claw-tests.asd
==============================================================================
--- (empty file)
+++ trunk/main/claw-core/claw-tests.asd Tue Jan 22 01:44:06 2008
@@ -0,0 +1,38 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: claw-tests.asd $
+
+;;; Copyright (c) 2008, Andrea Chiumenti. 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 :claw-tests
+ :name "claw-tests"
+ :author "Andrea Chiumenti"
+ :description "Tests for cl-webobjects"
+ :depends-on (:claw)
+ :components ((:module tests
+ :components ((:file "packages")
+ (:file "test1" :depends-on ("packages"))))))
+
Added: trunk/main/claw-core/claw.asd
==============================================================================
--- (empty file)
+++ trunk/main/claw-core/claw.asd Tue Jan 22 01:44:06 2008
@@ -0,0 +1,42 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: claw.asd $
+
+;;; Copyright (c) 2008, Andrea Chiumenti. 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 :claw
+ :name "claw"
+ :author "Andrea Chiumenti"
+ :description "Common Lisp Active Web.A famework to write web applications"
+ :depends-on (:hunchentoot :alexandria :cl-ppcre)
+ :components ((:module src
+ :components ((:file "packages")
+ (:file "misc" :depends-on ("packages"))
+ (:file "hunchentoot-overrides" :depends-on ("packages"))
+ (:file "tags" :depends-on ("misc"))
+ (:file "components" :depends-on ("tags"))
+ (:file "lisplet" :depends-on ("components"))
+ (:file "server" :depends-on ("lisplet"))))))
Added: trunk/main/claw-core/src/components.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-core/src/components.lisp Tue Jan 22 01:44:06 2008
@@ -0,0 +1,207 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/components.lisp $
+
+;;; Copyright (c) 2008, Andrea Chiumenti. 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 :claw)
+
+(defgeneric cform-rewinding-p (obj page-obj)
+ (:documentation "Internal method to determine, during the rewinding phase, if the COMP has been fired for calling its action.
+- OBJ the wcomponent instance
+- PAGE-OBJ the wcomponent owner page"))
+
+;--------------------------------------------------------------------------------
+
+(defcomponent cform () ()
+ (:documentation "This component render as a FORM tag class, but it is aware of
+the request cycle and is able to fire an action on rewind"))
+
+(defmethod cform-rewinding-p ((obj cform) (pobj page))
+ (string= (htcomponent-client-id obj)
+ (page-req-parameter pobj *rewind-parameter*)))
+
+(defmethod wcomponent-parameters ((o cform))
+ (list :id :required :action nil))
+
+(defmethod wcomponent-template((o cform))
+ (let ((client-id (htcomponent-client-id o)))
+ (when (null client-id)
+ (setf client-id ""))
+ (form> :static-id client-id
+ :name client-id
+ (wcomponent-informal-parameters o)
+ (input> :name *rewind-parameter*
+ :type "hidden"
+ :value client-id)
+ (htcomponent-body o))))
+
+(defmethod wcomponent-before-rewind ((obj cform) (pobj page))
+ (setf (page-current-form pobj) obj))
+
+(defmethod wcomponent-after-rewind ((obj cform) (pobj page))
+ (let ((action (wcomponent-parameter-value obj :action)))
+ (unless (or (null action) (null (cform-rewinding-p obj pobj)))
+ (funcall (fdefinition action) pobj))
+ (setf (page-current-form pobj) nil)))
+
+;--------------------------------------------------------------------------------
+
+(defcomponent action-link (cform) ()
+ (:documentation "This component behaves like a CFORM, firing it's associated action once clicked.
+It renders as a normal link."))
+
+(defmethod wcomponent-reserved-parameters ((o action-link))
+ '(:href))
+
+(defmethod wcomponent-template((o action-link))
+ (let ((client-id (htcomponent-client-id o)))
+ (when (null client-id)
+ (setf client-id ""))
+ (a> :static-id client-id
+ :href (format nil "?~a=~a" *rewind-parameter* client-id)
+ (wcomponent-informal-parameters o)
+ (htcomponent-body o))))
+
+;---------------------------------------------------------------------------------------
+
+(defcomponent cinput ()
+ ((result-as-list :initarg :result-as-list
+ :accessor cinput-result-as-list))
+ (:default-initargs :result-as-list nil)
+ (:documentation "Request cycle aware component the renders as an INPUT tag class"))
+
+(defmethod wcomponent-parameters ((o cinput))
+ (list :id :required :reader nil :writer nil :visit-object nil :accessor nil :type :required))
+
+(defmethod wcomponent-reserved-parameters ((o cinput))
+ '(:value :name))
+
+(defmethod wcomponent-template ((obj cinput))
+ (let ((client-id (htcomponent-client-id obj))
+ (type (wcomponent-parameter-value obj :type))
+ (visit-object (wcomponent-parameter-value obj :visit-object))
+ (accessor (wcomponent-parameter-value obj :accessor))
+ (reader (wcomponent-parameter-value obj :reader))
+ (value ""))
+ (when (null visit-object)
+ (setf visit-object (htcomponent-page obj)))
+ (if (and (null reader) accessor)
+ (setf value (funcall (fdefinition accessor) visit-object))
+ (setf value (funcall (fdefinition reader) visit-object)))
+ (input> :static-id client-id
+ :type type
+ :name client-id
+ :value value
+ (wcomponent-informal-parameters obj))))
+
+(defmethod wcomponent-after-rewind ((obj cinput) (pobj page))
+ (let ((visit-object (wcomponent-parameter-value obj :visit-object))
+ (accessor (wcomponent-parameter-value obj :accessor))
+ (writer (wcomponent-parameter-value obj :writer))
+ (new-value (page-req-parameter pobj
+ (htcomponent-client-id obj)
+ (cinput-result-as-list obj))))
+ (unless (null new-value)
+ (when (null visit-object)
+ (setf visit-object (htcomponent-page obj)))
+ (if (and (null writer) accessor)
+ (funcall (fdefinition `(setf ,accessor)) new-value visit-object)
+ (funcall (fdefinition writer) new-value visit-object)))))
+
+;---------------------------------------------------------------------------------------
+(defcomponent csubmit () ()
+ (:documentation "This component render as an INPUT tag class ot type submit, but
+can override the default CFORM action, using its own associated action"))
+
+(defmethod wcomponent-parameters ((o csubmit))
+ (list :id :required :value :required :action nil))
+
+(defmethod wcomponent-reserved-parameters ((o csubmit))
+ '(:type :name))
+
+(defmethod wcomponent-template ((obj csubmit))
+ (let ((client-id (htcomponent-client-id obj))
+ (value (wcomponent-parameter-value obj :value)))
+ (input> :static-id client-id
+ :type "submit"
+ :name client-id
+ :value value
+ (wcomponent-informal-parameters obj))))
+
+(defmethod wcomponent-after-rewind ((obj csubmit) (pobj page))
+ (let ((action (wcomponent-parameter-value obj :action))
+ (current-form (page-current-form pobj))
+ (submitted-p (page-req-parameter pobj (htcomponent-client-id obj))))
+ (unless (or (null current-form) (null submitted-p) (null action))
+ (setf (getf (wcomponent-parameters current-form) :action) action))))
+;-----------------------------------------------------------------------------
+(defcomponent submit-link (csubmit) ()
+ (:documentation "This component renders as a normal link, but behaves like a CSUBMIT,
+so it can be used instead of CSUBMIT when needed"))
+
+(defmethod wcomponent-reserved-parameters ((o submit-link))
+ '(:href))
+
+(defmethod wcomponent-template ((obj submit-link))
+ (let* ((id (htcomponent-client-id obj))
+ (submit-id (generate-id id)))
+ (list
+ (input> :static-id submit-id
+ :style "display:none;"
+ :type "submit"
+ :name id
+ :value "-")
+ (a> :static-id id
+ :href (format nil "javascript:document.getElementById('~a').click();" submit-id)
+ (wcomponent-informal-parameters obj)
+ (htcomponent-body obj)))))
+
+;--------------------------------------------------------------------------
+
+(defcomponent cselect (cinput) ()
+ (:default-initargs :result-as-list t)
+ (:documentation "This component renders as a normal SELECT tag class,
+but it is request cycle aware."))
+
+(defmethod wcomponent-parameters :around ((obj cselect))
+ (declare (ignore obj))
+ (let ((params (call-next-method)))
+ (remf params :reader)
+ (remf params :type)
+ params))
+
+(defmethod wcomponent-reserved-parameters ((obj cselect))
+ (declare (ignore obj))
+ '(:type :name))
+
+(defmethod wcomponent-template ((obj cselect))
+ (let ((client-id (htcomponent-client-id obj)))
+ (select> :static-id client-id
+ :name client-id
+ (wcomponent-informal-parameters obj)
+ (htcomponent-body obj))))
+
Added: trunk/main/claw-core/src/hunchentoot-overrides.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-core/src/hunchentoot-overrides.lisp Tue Jan 22 01:44:06 2008
@@ -0,0 +1,238 @@
+;;; -*- 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)
+
+(defgeneric realm (request)
+ (:documentation "Returns the realm under which the request has been sent.
+A realm is used to group resources under a common 'place', and is used for registered web applications
+to have different or common sessions for a give user."))
+(defgeneric (setf realm) (value request)
+ (:documentation "Sets the realm under which the request has been sent, where value is the realm name.
+A realm is used to group resources under a common 'place', and is used for registered web applications
+to have different or common sessions for a give user."))
+
+(defmethod realm ((request request))
+ (aux-request-value 'realm request))
+
+(defmethod (setf realm) (value (request request))
+ (setf (aux-request-value 'realm request) value)
+ (session-realm-verify request))
+
+;;;-------------------------------------------------------------------------------
+
+(defclass session ()
+ ((session-id :initform (get-next-session-id)
+ :reader session-id
+ :type integer
+ :documentation "The unique ID \(an INTEGER) of the session.")
+ (session-realm :initform (realm *request*)
+ :reader session-realm
+ :documentation "Defines a realm for this session.
+A realm is injected by *request* aux parameter, and is used to group resources that will share this session object.")
+ (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 realm)
+ "Create a uniquely encoded session string based on the values ID,
+USER-AGENT, REMOTE-ADDR, START and REALM"
+ ;; *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~@[~A~]"
+ *session-secret*
+ id
+ (and *use-user-agent-for-sessions*
+ user-agent)
+ (and *use-remote-addr-for-sessions*
+ remote-addr)
+ start
+ realm)))))
+
+(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)
+ (session-realm session)))
+
+
+(defun session-realm-verify (request)
+ "Once a session is verified for a given user this function verifies that it belongs to the request realm, so
+that session and request realm must be the same."
+ (when (session request)
+ (let
+ ((req-realm (realm request))
+ (realm (session-realm (session request))))
+ (when (string-not-equal req-realm realm)
+ (log-message :info "2) $$$$$~a$$$$$" (aux-request-value 'realm request))
+ (log-message :info "#####~a ~a#####" req-realm realm)
+ (setf (session request) nil)
+ (setf *session* nil)))))
+
+(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))
+ (realm (when session (session-realm session))))
+ (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)
+ realm)))
+ (when *reply*
+ (cond ((null session)
+ (log-message :notice "No session for session identifier '~A' (User-Agent: '~A', IP: '~A', REALM: '~A')"
+ session-identifier user-agent remote-addr realm))
+ (t
+ (log-message :warning "Fake session identifier '~A' (User-Agent: '~A', IP: '~A', REALM: '~A')"
+ session-identifier user-agent remote-addr realm))))
+ (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 start-session (&optional (path "/"))
+ "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.
+This function slightly differs from standard hunchentoot implementation because
+it can bound a session to a specific url inside the same server instance.
+The path optional parameter has sense when the cookies are enabled, and bounds
+resources under the given path to a specific session"
+ (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 path)
+ (setq *session* session)))
+
+;;;--------------------------- dispatchers ----------------------------------------------
+
+(defun create-prefix-dispatcher (prefix page-function &optional (realm "Hunchentoot"))
+ "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.
+The optional parameter realm is a string that identifies the realm under which the request is displatching.
+A realm is used to group resources under a common 'place', and is used for registered web applications
+to have different or common sessions for a give user."
+ (lambda (request)
+ (let ((mismatch (mismatch (script-name request) prefix
+ :test #'char=)))
+ (when (and (or (null mismatch)
+ (>= mismatch (length prefix)))
+ page-function)
+ (setf (realm request) realm)
+ page-function))))
+
+(defun create-regex-dispatcher (regex page-function &optional (realm "Hunchentoot"))
+ "Creates a dispatch function whipch will dispatch to the
+function denoted by PAGE-FUNCTION if the file name of the current
+request matches the CL-PPCRE regular expression REGEX.
+The optional parameter realm is a string that identifies the realm under which the request is displatching.
+A realm is used to group resources under a common 'place', and is used for registered web applications
+to have different or common sessions for a give user."
+ (let ((scanner (create-scanner regex)))
+ (lambda (request)
+ (when (and (scan scanner (script-name request))
+ page-function)
+ (setf (realm request) realm)
+ page-function))))
+
Added: trunk/main/claw-core/src/lisplet.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-core/src/lisplet.lisp Tue Jan 22 01:44:06 2008
@@ -0,0 +1,109 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/lisplet.lisp $
+
+;;; Copyright (c) 2008, Andrea Chiumenti. 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 :claw)
+
+;(print *this-file*)
+
+(defgeneric lisplet-register-page-location (obj page-class location &optional welcome-pagep))
+(defgeneric lisplet-register-resource-location (obj uri url))
+
+(defgeneric lisplet-dispatch-request (obj))
+(defgeneric lisplet-dispatch-method (obj))
+
+
+(defclass lisplet ()
+ ((base-path :initarg :base-path
+ :reader lisplet-base-path)
+ (welcome-page :initarg :welcome-page
+ :accessor lisplet-welcome-page)
+ (realm :initarg :realm
+ :reader lisplet-realm)
+ (pages :initform nil
+ :accessor lisplet-pages)
+ (page404 :initarg :page404
+ :accessor lisplet-page404))
+ (:default-initargs :welcome-page nil :realm nil :page404 (make-instance 'page404)))
+
+(defun build-lisplet-location (lisplet location)
+ (let ((server-base-path *clawserver-base-path*)
+ (base-path (lisplet-base-path lisplet)))
+ (if location
+ (setf location (format nil "~a/~a" base-path location))
+ (setf location base-path))
+ (unless (null server-base-path)
+ (setf location (format nil "~a~a" server-base-path location)))
+ location))
+
+(defmethod lisplet-register-page-location ((obj lisplet) page-class location &optional welcome-pagep)
+ (let ((pages (lisplet-pages obj))
+ (new-location (build-lisplet-location obj location)))
+ (setf (lisplet-pages obj)
+ (sort-dispatchers (push-dispatcher
+ (cons new-location
+ (create-prefix-dispatcher new-location
+ #'(lambda ()
+ (with-output-to-string
+ (*standard-output*)
+ (page-render (make-instance page-class :lisplet obj :url new-location))))
+ (lisplet-realm obj)))
+ pages)))
+ (when welcome-pagep
+ (setf (lisplet-welcome-page obj) new-location))))
+
+(defmethod lisplet-register-resource-location ((obj lisplet) resource-path location)
+ (let ((pages (lisplet-pages obj))
+ (new-location (build-lisplet-location obj location)))
+ (set (lisplet-pages obj)
+ (sort-dispatchers (push-dispatcher
+ (cons new-location
+ (create-folder-dispatcher-and-handler new-location resource-path))
+ pages)))))
+
+(defmethod lisplet-dispatch-request ((obj lisplet))
+ (let ((pages (lisplet-pages obj)))
+ (loop for dispatcher in pages
+ for action = (funcall (cdr dispatcher) *request*)
+ when action return (funcall action))))
+
+(defmethod lisplet-dispatch-method ((obj lisplet))
+ (let ((page404 (lisplet-page404 obj))
+ (result nil)
+ (base-path (build-lisplet-location obj nil))
+ (uri (request-uri))
+ (welcome-page (lisplet-welcome-page obj)))
+ (if (and welcome-page (string= uri base-path))
+ (progn
+ (redirect (lisplet-welcome-page obj))
+ t)
+ (progn
+ (setf result (lisplet-dispatch-request obj))
+ (when (null result)
+ (setf result (with-output-to-string (*standard-output*) (page-render page404))))
+ result))))
Added: trunk/main/claw-core/src/misc.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-core/src/misc.lisp Tue Jan 22 01:44:06 2008
@@ -0,0 +1,63 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/tags.lisp $
+
+;;; Copyright (c) 2008, Andrea Chiumenti. 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 :claw)
+
+
+(defun strings-to-jsarray (strings)
+ "Transforms a list of strings into a javascript array."
+ (let ((st-size (length strings))
+ (items ""))
+ (cond ((= st-size 0) "[]")
+ ((= st-size 1) (format nil "[~a]" (prin1-to-string (first strings))))
+ (t (format nil (format nil "[~a~a]"
+ (prin1-to-string (first strings))
+ (progn
+ (dolist (str (rest strings))
+ (setf items (format nil "~a,~a"
+ items (prin1-to-string str))))
+ items)))))))
+
+(defun sort-dispatchers (dispatchers)
+ "Sorts a list of dispatcher. A dispatcher is a cons where the car is the url
+where the dispatcher method(the cdr) will be called."
+ (sort dispatchers #'(lambda (item1 item2)
+ (string-not-lessp (car item1) (car item2)))))
+
+(defun remove-dispatcher-by-location (location dispatchers)
+ "Removes a dispatcher cons (location.dispatcher-method) checking its car
+against the location parameter"
+ (delete-if #'(lambda (dispatcher) (string= (car dispatcher) location)) dispatchers))
+
+(defun push-dispatcher (dispatcher dispatchers)
+ "Isert a new dispatcher into dispatchers, or replace the one that has the same location
+registered (its car)."
+ (let ((result (remove-dispatcher-by-location (car dispatcher) dispatchers)))
+ (setf result (push dispatcher dispatchers))))
+
Added: trunk/main/claw-core/src/packages.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-core/src/packages.lisp Tue Jan 22 01:44:06 2008
@@ -0,0 +1,247 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/package.lisp $
+
+;;; Copyright (c) 2008, Andrea Chiumenti. 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)
+
+(export 'HUNCHENTOOT::REQUEST-REALM 'HUNCHENTOOT)
+(export 'HUNCHENTOOT::SESSION-REALM 'HUNCHENTOOT)
+
+(defpackage :claw
+ (:use :cl :hunchentoot :alexandria :cl-ppcre)
+ (:export :*html-4.01-strict*
+ :*html-4.01-transitional*
+ :*html-4.01-frameset*
+ :*xhtml-1.0-strict*
+ :*xhtml-1.0-transitional*
+ :*xhtml-1.0-frameset*
+ :*default-encoding*
+ :*rewind-parameter*
+ :*clawserver-base-path*
+ ;:request-realm
+ :request-id-table-map
+ ;:dyna-id
+ :tag-empty-p
+ :tag-symbol-class
+ :strings-to-jsarray
+ :empty-string-p
+ :build-tagf
+ :parse-htcomponent-function
+ :page ;page classes hadle the whole rendering cycle
+ :page-writer
+ :page-can-print
+ :page-url
+ :page-lisplet
+ :page-current-form
+ :page-req-parameter
+ :page-json-id-list
+ :page-format
+ :page-format-raw
+ :page-script-files
+ :page-stylesheet-files
+ :page-class-initscripts
+ :page-instance-initscripts
+ :page-indent
+ :page-xmloutput
+ :page-doc-type
+ :htclass-body
+ :htcomponent
+ :htcomponent-page
+ :htcomponent-body
+; :setf-htcomponent-page
+ :htcomponent-attributes
+ :htcomponent-can-print
+ :htcomponent-empty
+ :htcomponent-client-id
+ :htcomponent-script-files
+ :htcomponent-stylesheet-files
+ :htcomponent-class-initscripts
+ :htcomponent-instance-initscript
+ :tag ;class for tags that accept body
+ :tag-name
+ :tag-render-starttag
+ :tag-render-endtag
+ :htbody
+ :page-body-init-scripts
+ :htscript
+ :htlink
+ :hthead
+ :htstring
+ :$>
+ :$raw>
+ ;empty tags definition
+ :area>
+ :base>
+ :basefont>
+ :br>
+ :col>
+ :frame>
+ :hr>
+ :img>
+ :input>
+ :isindex>
+ :link>
+ :meta>
+ :param>
+ ;standard tags
+ :a>
+ :abbr>
+ :acronym>
+ :address>
+ :applet>
+ :b>
+ :bdo>
+ :big>
+ :blockquote>
+ :body>
+ :button>
+ :caption>
+ :center>
+ :cite>
+ :code>
+ :colgroup>
+ :dd>
+ :del>
+ :dfn>
+ :dir>
+ :div>
+ :dl>
+ :dt>
+ :em>
+ :fieldset>
+ :font>
+ :form>
+ :frameset>
+ :h1>
+ :h2>
+ :h3>
+ :h4>
+ :h5>
+ :h6>
+ :head>
+ :html>
+ :i>
+ :iframe>
+ :ins>
+ :kbd>
+ :label>
+ :legend>
+ :li>
+ :map>
+ :menu>
+ :noframes>
+ :noscript>
+ :object>
+ :ol>
+ :optgroup>
+ :option>
+ :p>
+ :pre>
+ :q>
+ :s>
+ :samp>
+ :script>
+ :select>
+ :small>
+ :span>
+ :strike>
+ :strong>
+ :style>
+ :sub>
+ :sup>
+ :table>
+ :tbody>
+ :td>
+ :textarea>
+ :tfoot>
+ :th>
+ :thead>
+ :title>
+ :tr>
+ :tt>
+ :u>
+ :ul>
+ :var>
+ ;; class modifiers
+ :page-content
+ :page-render
+ :generate-id
+ :wcomponent
+ :wcomponent-parameters
+ :wcomponent-informal-parameters
+ :wcomponent-allow-informal-parametersp
+ :wcomponent-template
+ :wcomponent-parameter-value
+ :wcomponent-before-rewind
+ :wcomponent-after-rewind
+ :wcomponent-before-prerender
+ :wcomponent-after-prerender
+ :wcomponent-before-render
+ :wcomponent-after-render
+ :make-component
+ :defcomponent
+ :cform
+ :cform>
+ :action-link
+ :action-link>
+ :cinput
+ :cinput>
+ :cselect
+ :cselect>
+ :csubmit
+ :csubmit>
+ :submit-link
+ :submit-link>
+ :lisplet
+ :lisplet-realm
+ :lisplet-pages
+ :lisplet-base-path
+ :lisplet-dispatch-method
+ :lisplet-register-page-location
+ :lisplet-register-resource-location
+ ;; clawserver
+ :clawserver
+ :clawserver-register-lisplet
+ :clawserver-unregister-lisplet
+ :clawserver-start
+ :clawserver-stop
+ :clawserver-port
+ :clawserver-sslport
+ :clawserver-address
+ :clawserver-name
+ :clawserver-sslname
+ :clawserver-mod-lisp-p
+ :clawserver-use-apache-log-p
+ :clawserver-input-chunking-p
+ :clawserver-read-timeout
+ :clawserver-write-timeout
+ #+(and :unix (not :win32)) :clawserver-setuid
+ #+(and :unix (not :win32)) :clawserver-setgid
+ #-:hunchentoot-no-ssl :clawserver-ssl-certificate-file
+ #-:hunchentoot-no-ssl :clawserver-ssl-privatekey-file
+ #-:hunchentoot-no-ssl :clawserver-ssl-privatekey-password))
Added: trunk/main/claw-core/src/server.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-core/src/server.lisp Tue Jan 22 01:44:06 2008
@@ -0,0 +1,389 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/server.lisp $
+
+;;; Copyright (c) 2008, Andrea Chiumenti. 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 :claw)
+
+(defgeneric clawserver-register-lisplet (obj lisplet-obj)
+ (:documentation "This method registers a lisplet for request dispatching
+- OBJ the CLAWSERVER instance
+- LISPLET-OBJ the LISPLET instance"))
+
+(defgeneric clawserver-unregister-lisplet (obj lisplet-obj)
+ (:documentation "This method unregisters a lisplet from request dispatching
+- OBJ the CLAWSERVER instance
+- LISPLET-OBJ the LISPLET instance"))
+
+(defgeneric clawserver-dispatch-request (obj)) ;internal
+(defgeneric clawserver-dispatch-method (obj)) ;internal
+
+(defgeneric clawserver-start (obj)
+ (:documentation "Starts the server"))
+(defgeneric clawserver-stop (obj)
+ (:documentation "Stops the server"))
+
+(defgeneric (setf clawserver-port) (val obj))
+(defgeneric (setf clawserver-sslport) (val obj))
+(defgeneric (setf clawserver-address) (val obj))
+(defgeneric (setf clawserver-name) (val obj))
+(defgeneric (setf clawserver-sslname) (val obj))
+(defgeneric (setf clawserver-mod-lisp-p) (val obj))
+(defgeneric (setf clawserver-use-apache-log-p) (val obj))
+(defgeneric (setf clawserver-input-chunking-p) (val obj))
+(defgeneric (setf clawserver-read-timeout) (val obj))
+(defgeneric (setf clawserver-write-timeout) (val obj))
+#+(and :unix (not :win32)) (defgeneric (setf clawserver-setuid) (val obj))
+#+(and :unix (not :win32)) (defgeneric (setf clawserver-setgid) (val obj))
+#-:hunchentoot-no-ssl (defgeneric (setf clawserver-ssl-certificate-file) (val obj))
+#-:hunchentoot-no-ssl (defgeneric (setf clawserver-ssl-privatekey-file) (val obj))
+#-:hunchentoot-no-ssl (defgeneric (setf clawserver-ssl-privatekey-password) (val obj))
+
+
+(defclass page404 (page)
+ ((style :initform
+ "
+body {
+ font-family: arial, elvetica;
+ font-size: 7pt;
+}
+span.blue {
+ background-color: #525D76;
+ color: white;
+ font-weight: bolder;
+ margin-right: .25em;
+}
+p.h1, p.h2 {
+ background-color: #525D76;
+ color: white;
+ font-weight: bolder;
+ font-size: 2em;
+ margin: 0;
+ margin-bottom: .5em;
+}
+p.h2 {font-size: 1.5em;}"
+ :reader page404-style))
+ (:documentation "This page class is used to render
+the 404 (page not found) messages."))
+
+(defmethod page-content ((obj page404))
+ (html>
+ (head>
+ (title>
+ "404 Page not found")
+ (style>
+ (page404-style obj)))
+ (body>
+ (p>
+ (p> :class "h1"
+ (format nil "HTTP Status 404 - ~a" (request-uri *request*)))
+ (hr> :noshade "noshade")
+ (p>
+ (span> :class "blue"
+ ($> "type"))
+ "Status report")
+ (p>
+ (span> :class "blue"
+ "message")
+ (request-uri *request*))
+ (p>
+ (span> :class "blue"
+ "description")
+ (format nil "The requested resource (~a) is not available." (request-uri *request*)))
+ (hr> :noshade "noshade"))
+ (p> :class "h2"
+ "cl-webobject server"))))
+
+(defclass clawserver ()
+ ((port :initarg :port
+ :reader clawserver-port)
+ (sslport :initarg :sslport
+ :reader clawserver-sslport)
+ (address :initarg :address
+ :reader clawserver-address)
+ (name :initarg :name
+ :reader clawserver-name)
+ (sslname :initarg :sslname
+ :reader clawserver-sslname)
+ (mod-lisp-p :initarg :mod-lisp-p
+ :reader clawserver-mod-lisp-p)
+ (use-apache-log-p :initarg :use-apache-log-p
+ :reader clawserver-use-apache-log-p)
+ (input-chunking-p :initarg :input-chunking-p
+ :reader clawserver-input-chunking-p)
+ (read-timeout :initarg :read-timeout
+ :reader clawserver-read-timeout)
+ (write-timeout :initarg :write-timeout
+ :reader clawserver-write-timeout)
+ #+(and :unix (not :win32)) (setuid :initarg :setuid
+ :reader clawserver-setuid)
+ #+(and :unix (not :win32)) (setgid :initarg :setgid
+ :reader clawserver-setgid)
+ #-:hunchentoot-no-ssl (ssl-certificate-file :initarg :ssl-certificate-file
+ :reader clawserver-ssl-certificate-file)
+ #-:hunchentoot-no-ssl (ssl-privatekey-file :initarg :ssl-privatekey-file
+ :reader clawserver-ssl-privatekey-file)
+ #-:hunchentoot-no-ssl (ssl-privatekey-password :initarg :ssl-privatekey-password
+ :reader clawserver-ssl-privatekey-password)
+ (server :initform nil
+ :accessor clawserver-server)
+ (sslserver :initform nil
+ :accessor clawserver-sslserver)
+ (lisplets :initform nil
+ :accessor clawserver-lisplets)
+ (page404 :initarg :page404
+ :accessor clawserver-page404))
+ (:default-initargs :address nil
+ :name (gensym)
+ :sslname (gensym)
+ :port 80
+ :sslport 443
+ :mod-lisp-p nil
+ :input-chunking-p t
+ :read-timeout *default-read-timeout*
+ :write-timeout *default-write-timeout*
+ #+(and :unix (not :win32)) :setuid nil
+ #+(and :unix (not :win32)) :setgid nil
+ #-:hunchentoot-no-ssl :ssl-certificate-file nil
+ #-:hunchentoot-no-ssl :ssl-privatekey-password nil
+ :page404 (make-instance 'page404))
+ (:documentation "CLAWSERVER is built around huncentoot and has the
+instructions for lisplet dispatching, so use this class to start and stop
+hunchentoot server."))
+
+(defmethod initialize-instance :after ((obj clawserver) &rest keys)
+ (let ((use-apache-log-p (getf keys :use-apache-log-p :undefined))
+ #-:hunchentoot-no-ssl (ssl-privatekey-file (getf keys :ssl-privatekey-file :undefined)))
+ (when (eq use-apache-log-p :undefined)
+ (setf (clawserver-use-apache-log-p obj) (getf keys :mod-lisp-p)))
+ #-:hunchentoot-no-ssl (when (eq ssl-privatekey-file :undefined)
+ (setf (clawserver-ssl-privatekey-file obj) (getf keys :ssl-certificate-file)))))
+
+(defmethod clawserver-register-lisplet ((obj clawserver) (lisplet-obj lisplet))
+ (let ((lisplets (clawserver-lisplets obj))
+ (server-base-path *clawserver-base-path*)
+ (location (lisplet-base-path lisplet-obj)))
+ (unless (null server-base-path)
+ (setf location (format nil "~@[~a~]~a" server-base-path location)))
+ (setf (clawserver-lisplets obj) (sort-dispatchers (push-dispatcher
+ (cons location
+ (create-prefix-dispatcher
+ location
+ #'(lambda ()
+ (lisplet-dispatch-method lisplet-obj))
+ (lisplet-realm lisplet-obj)))
+ lisplets)))))
+
+(defmethod clawserver-unregister-lisplet ((obj clawserver) (lisplet-obj lisplet))
+ (let ((lisplets (clawserver-lisplets obj))
+ (server-base-path *clawserver-base-path*)
+ (location (lisplet-base-path lisplet-obj)))
+ (unless (null server-base-path)
+ (setf location (format nil "~@[~a~]~a" server-base-path location)))
+ (remove-dispatcher-by-location location lisplets)))
+
+
+;;;-------------------------- WRITERS ----------------------------------------
+
+(defmethod (setf clawserver-port) (val (obj clawserver))
+ (unless (null (clawserver-server obj))
+ (error "Cannot change port when server is started"))
+ (setf (slot-value obj 'port) val))
+
+(defmethod (setf clawserver-sslport) (val (obj clawserver))
+ (unless (null (clawserver-server obj))
+ (error "Cannot change SSL port when server is started"))
+ (setf (slot-value obj 'sslport) val))
+
+(defmethod (setf clawserver-address) (val (obj clawserver))
+ (unless (null (clawserver-server obj))
+ (error "Cannot change binding address when server is started"))
+ (setf (slot-value obj 'address) val))
+
+(defmethod (setf clawserver-name) (val (obj clawserver))
+ (unless (null (clawserver-server obj))
+ (setf (server-name (clawserver-server obj)) val))
+ (setf (slot-value obj 'name) val))
+
+(defmethod (setf clawserver-sslname) (val (obj clawserver))
+ (unless (null (clawserver-sslserver obj))
+ (setf (server-name (clawserver-sslserver obj)) val))
+ (setf (slot-value obj 'sslname) val))
+
+(defmethod (setf clawserver-mod-lisp-p) (val (obj clawserver))
+ (unless (null (clawserver-server obj))
+ (error "Cannot change mod-lisp property when server is started"))
+ (setf (slot-value obj 'mod-lisp-p) val))
+
+(defmethod (setf clawserver-use-apache-log-p) (val (obj clawserver))
+ (unless (null (clawserver-server obj))
+ (error "Cannot change logging property when server is started"))
+ (setf (slot-value obj 'use-apache-log-p) val))
+
+(defmethod (setf clawserver-input-chunking-p) (val (obj clawserver))
+ (unless (null (clawserver-server obj))
+ (error "Cannot change chunking property when server is started"))
+ (setf (slot-value obj 'input-chunking-p) val))
+
+(defmethod (setf clawserver-read-timeout) (val (obj clawserver))
+ (unless (null (clawserver-server obj))
+ (error "Cannot change read timeout property when server is started"))
+ (setf (slot-value obj 'read-timeout) val))
+
+(defmethod (setf clawserver-write-timeout) (val (obj clawserver))
+ (unless (null (clawserver-server obj))
+ (error "Cannot change write timeout property when server is started"))
+ (setf (slot-value obj 'write-timeout) val))
+
+#+(and :unix (not :win32)) (defmethod (setf clawserver-setuid) (val (obj clawserver))
+ (unless (null (clawserver-server obj))
+ (error "Cannot change uid property when server is started"))
+ (setf (slot-value obj 'setuid) val))
+
+#+(and :unix (not :win32)) (defmethod (setf clawserver-setgid) (val (obj clawserver))
+ (unless (null (clawserver-server obj))
+ (error "Cannot change gid property when server is started"))
+ (setf (slot-value obj 'setgid) val))
+
+#-:hunchentoot-no-ssl (defmethod (setf clawserver-ssl-certificate-file) (val (obj clawserver))
+ (unless (null (clawserver-server obj))
+ (error "Cannot change ssl certificate file property when server is started"))
+ (setf (slot-value obj 'ssl-certificate-file) val))
+
+#-:hunchentoot-no-ssl (defmethod (setf clawserver-ssl-privatekey-file) (val (obj clawserver))
+ (unless (null (clawserver-server obj))
+ (error "Cannot change ssl privatekey file property when server is started"))
+ (setf (slot-value obj 'ssl-privatekey-file) val))
+
+#-:hunchentoot-no-ssl (defmethod (setf clawserver-ssl-privatekey-password) (val (obj clawserver))
+ (unless (null (clawserver-server obj))
+ (error "Cannot change ssl privatekey password property when server is started"))
+ (setf (slot-value obj 'ssl-privatekey-password) val))
+
+;;;-------------------------- METHODS ----------------------------------------
+(defmethod clawserver-dispatch-request ((obj clawserver))
+ (let ((lisplets (clawserver-lisplets obj)))
+ (loop for dispatcher in lisplets
+ for action = (funcall (cdr dispatcher) *request*)
+ when action return (funcall action))))
+
+(defmethod clawserver-dispatch-method ((obj clawserver))
+ (let ((page404 (clawserver-page404 obj))
+ (result nil))
+ (progn
+ (setf result (clawserver-dispatch-request obj))
+ (if (null result)
+ #'(lambda () (with-output-to-string (*standard-output*) (page-render page404)))
+ #'(lambda () result)))))
+
+(defmethod clawserver-start ((obj clawserver))
+ (let ((port (clawserver-port obj))
+ (sslport (clawserver-sslport obj))
+ (address (clawserver-address obj))
+ (dispatch-table (list #'(lambda (request)
+ (declare (ignorable request))
+ (clawserver-dispatch-method obj))))
+ (name (clawserver-name obj))
+ (sslname (clawserver-sslname obj))
+ (mod-lisp-p (clawserver-mod-lisp-p obj))
+ (use-apache-log-p (clawserver-use-apache-log-p obj))
+ (input-chunking-p (clawserver-input-chunking-p obj))
+ (read-timeout (clawserver-read-timeout obj))
+ (write-timeout (clawserver-write-timeout obj))
+ (uid (clawserver-setuid obj))
+ (gid (clawserver-setgid obj))
+ (ssl-certificate-file (clawserver-ssl-certificate-file obj))
+ (ssl-privatekey-file (clawserver-ssl-privatekey-file obj))
+ (ssl-privatekey-password (clawserver-ssl-privatekey-password obj)))
+ (progn
+ (setf (clawserver-server obj)
+ (start-server :port port
+ :address address
+ :dispatch-table dispatch-table
+ :name name
+ :mod-lisp-p mod-lisp-p
+ :use-apache-log-p use-apache-log-p
+ :input-chunking-p input-chunking-p
+ :read-timeout read-timeout
+ :write-timeout write-timeout
+ #+(and :unix (not :win32)) :setuid uid
+ #+(and :unix (not :win32)) :setgid gid))
+ #-:hunchentoot-no-ssl (when ssl-certificate-file
+ (setf (clawserver-sslserver obj)
+ (start-server :port sslport
+ :address address
+ :dispatch-table dispatch-table
+ :name sslname
+ :mod-lisp-p mod-lisp-p
+ :use-apache-log-p use-apache-log-p
+ :input-chunking-p input-chunking-p
+ :read-timeout read-timeout
+ :write-timeout write-timeout
+ #+(and :unix (not :win32)) :setuid uid
+ #+(and :unix (not :win32)) :setgid gid
+ :ssl-certificate-file ssl-certificate-file
+ :ssl-privatekey-file ssl-privatekey-file
+ :ssl-privatekey-password ssl-privatekey-password))))))
+
+(defmethod clawserver-stop ((obj clawserver))
+ (progn
+ (setf (clawserver-server obj) (stop-server (clawserver-server obj)))
+ (when (clawserver-sslserver obj)
+ (setf (clawserver-sslserver obj) (stop-server (clawserver-sslserver obj))))))
+;;;----------------------------------------------------------------------------
+(defun start-clawserver (clawserver-obj
+ &key (port 80)
+ address
+ (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)
+ (start-server :port port
+ :address address
+ :dispatch-table (list #'(lambda (request)
+ (declare (ignorable request))
+ (clawserver-dispatch-method clawserver-obj)))
+ :name name
+ :mod-lisp-p mod-lisp-p
+ :use-apache-log-p use-apache-log-p
+ :input-chunking-p input-chunking-p
+ :read-timeout read-timeout
+ :write-timeout write-timeout
+ #+(and :unix (not :win32)) :setuid setuid
+ #+(and :unix (not :win32)) :setgid setgid
+ #-:hunchentoot-no-ssl :ssl-certificate-file ssl-certificate-file
+ #-:hunchentoot-no-ssl :ssl-privatekey-file ssl-privatekey-file
+ #-:hunchentoot-no-ssl :ssl-privatekey-password ssl-privatekey-password))
+
+
\ No newline at end of file
Added: trunk/main/claw-core/src/tags.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-core/src/tags.lisp Tue Jan 22 01:44:06 2008
@@ -0,0 +1,1042 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/tags.lisp $
+
+;;; Copyright (c) 2008, Andrea Chiumenti. 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 EXPRESSEDse
+;;; 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 :claw)
+
+
+
+(defgeneric page-req-parameter (obj name &optional as-list)
+ (:documentation "This method returns a request parameter given by NAME searching first
+into post parameters and, if no parameter found, into get prarmeters.
+The optional function parameter AS-LIST if true returns the result as list.
+When AS-LIST is true, if the searched parameter is found more then once, a list with
+all valuse given to param NAME is returned.
+ - OBJ is the page instance that must be given.
+ - NAME The parameter to search
+ - AS-LIST If true the result is returned as list, if false as string. Default: false"))
+
+(defgeneric page-json-id-list (obj)
+ (:documentation "This internal method is called to get a list of all the components by their id, that must be updated when
+an xhr request is sent from the browser.
+ - OBJ is the page instance that must be given"))
+
+(defgeneric page-content (obj)
+ (:documentation "This method returns the page content to be redered.
+ - OBJ is the page instance that must be given"))
+
+(defgeneric page-init (obj)
+ (:documentation "Internal method for page initialization.
+ - OBJ is the page instance that must be given"))
+
+(defgeneric page-render (obj)
+ (:documentation "This method is the main method fired from the framework to render the desired page and to handle all the request cycle.
+ - OBJ is the page instance that must be given"))
+
+(defgeneric page-init-injections (pobj)
+ (:documentation "This internal method is called during the request cycle phase to reset page slots that
+must be reinitialized during sub-phases (rewinding, pre-rendering, rendering).
+ - OBJ is the page instance that must be given"))
+
+(defgeneric page-render-headings (obj)
+ (:documentation "This internal method renders the html first lines that determine if the page is a html or a xhtml, along with the schema definition.
+ - OBJ is the page instance that must be given"))
+
+(defgeneric page-request-parameters (obj)
+ (:documentation "This internal method builds the get and post parameters into an hash table.
+ - OBJ is the page instance that must be given"))
+
+(defgeneric page-print-tabulation (obj)
+ (:documentation "This internal method is called during the rendering phase if tabulation is enabled. It writes the right amount
+of tabs chars to indent the page.
+ - OBJ is the page instance that must be given"))
+
+(defgeneric page-newline (obj)
+ (:documentation "This internal method simply writes the rest of page content on a new line when needed.
+ - OBJ is the page instance that must be given"))
+
+(defgeneric page-format (obj str &rest rest)
+ (:documentation "This internal method is the replacement of the FORMAT function. It is aware
+of an xhr request when the reply must be given as a json object. It also uses the default page output stream
+to render the output.
+ - OBJ is the page instance that must be given
+ - STR The format control
+ - REST The format arguments
+See http://www.lisp.org/HyperSpec/Body/fun_format.html#format for more info."))
+
+(defgeneric page-format-raw (obj str &rest rest)
+ (:documentation "This internal method is the replacement of the FORMAT.
+The difference with PAGE-FORMAT is that it prints out the result ignoring the json directive.
+It also uses the default page output stream as PAGE-FORMAT does to render the output.
+ - OBJ is the page instance that must be given
+ - STR The format control
+ - REST The format arguments
+See http://www.lisp.org/HyperSpec/Body/fun_format.html#format for more info."))
+
+(defgeneric page-body-init-scripts (page-obj)
+ (:documentation "During the render phase wcomponent instances inject their initialization scripts (javascript)
+that will be evaluated when the page has been loaded.
+This internal method is called to render these scripts.
+ - PAGE-OBJ is the page instance that must be given"))
+
+(defgeneric htbody-init-scripts-tag (page-obj)
+ (:documentation "Encloses the init inscance scripts injected into the page into a <script> tag component
+See PAGE-BODY-INIT-SCRIPTS form more info.
+ - PAGE-OBJ is the page instance that must be given"))
+
+(defgeneric htcomponent-rewind (obj page-obj)
+ (:documentation "This internal method is the first called during the request cycle phase.
+It is evaluated when a form action or an action-link action is fired. It is used to update all visit objects slots.
+ - OBJ is the htcomponent instance that must be rewound
+ - PAGE-OBJ is the page instance that must be given"))
+
+(defgeneric htcomponent-prerender (obj page-obj)
+ (:documentation "This internal method is the second sub phase during the request cycle phase.
+It is used to inject all wcomponent class scripts and stylesheets into the owner page.
+ - OBJ is the htcomponent instance that must be prerendered
+ - PAGE-OBJ is the page instance that must be given"))
+
+(defgeneric htcomponent-render (obj page-obj)
+ (:documentation "This internal method is the last called during the request cycle phase.
+It is used to effectively render the component into the page.
+ - OBJ is the htcomponent instance that must be rendered
+ - PAGE-OBJ is the page instance that must be given"))
+
+(defgeneric htcomponent-can-print (obj)
+ (:documentation "This internal method is used in an xhr call to determine
+if a component may be rendered into the reply
+ - OBJ is the htcomponent instance"))
+
+(defgeneric htcomponent-json-print-start-component (obj)
+ (:documentation "Internal method called to render the json reply during the render cycle phase
+on component start.
+ - OBJ is the htcomponent instance"))
+
+(defgeneric htcomponent-json-print-end-component (obj)
+ (:documentation "Internal method called to render the json reply during the render cycle phase
+on component end.
+ - OBJ is the htcomponent instance"))
+
+(defgeneric tag-render-starttag (obj page-obj)
+ (:documentation "Internal method to print out the opening html tag during the render phase
+ - OBJ is the tag instance
+ - PAGE-OBJ the page instance"))
+
+(defgeneric tag-render-endtag (obj page-obj)
+ (:documentation "Internal method to print out the closing html tag during the render phase
+ - OBJ is the tag instance
+ - PAGE-OBJ the page instance"))
+
+(defgeneric tag-render-attributes (obj page-obj)
+ (:documentation "Internal method to print out the attributes of an html tag during the render phase
+ - OBJ is the tag instance
+ - PAGE-OBJ the page instance"))
+
+(defgeneric (setf htcomponent-page) (page-obj obj)
+ (:documentation "Internal method to set the component owner page and to assign
+an unique id attribute when provided.
+ - OBJ is the tag instance
+ - PAGE-OBJ the page instance"))
+
+(defgeneric wcomponent-parameter-value (obj key)
+ (:documentation "Returns the value of a parameter passed to the wcomponent initialization
+function (the one generated with DEFCOMPONENT) or :UNDEFINED if not passed.
+ - OBJ is the wcomponent instance
+ - KEY the parameter key to query"))
+
+(defgeneric wcomponent-check-parameters(obj)
+ (:documentation "This internal method check if all :REQUIRED parameters are provided
+ - OBJ is the wcomponent instance"))
+
+(defgeneric wcomponent-parameters(obj)
+ (:documentation "This method returns class formal parameters as an alist (formal parameters are the ones expected by the component)
+ - OBJ is the wcomponent instance"))
+(defgeneric wcomponent-informal-parameters(obj)
+ (:documentation "This method returns class informal parameters as an alist (informal parameters are the ones not expected by the component,
+usually rendered as tag attributes withot any kind of evaluation)
+ - OBJ is the wcomponent instance"))
+
+(defgeneric wcomponent-before-rewind (obj page-obj)
+ (:documentation "Method called by the framework before the rewinding phase. It is intended to be eventually overridden in descendant classes.
+ - OBJ is the tag instance
+ - PAGE-OBJ the page instance"))
+
+(defgeneric wcomponent-after-rewind (obj page-obj)
+ (:documentation "Method called by the framework after the rewinding phase. It is intended to be eventually overridden in descendant classes.
+ - OBJ is the tag instance
+ - PAGE-OBJ the page instance"))
+(defgeneric wcomponent-before-prerender (obj page-obj)
+ (:documentation "Method called by the framework before the pre-rendering phase. It is intended to be eventually overridden in descendant classes.
+ - OBJ is the tag instance
+ - PAGE-OBJ the page instance"))
+
+(defgeneric wcomponent-after-prerender (obj page-obj)
+ (:documentation "Method called by the framework after the pre-rendering phase. It is intended to be eventually overridden in descendant classes.
+ - OBJ is the tag instance
+ - PAGE-OBJ the page instance"))
+(defgeneric wcomponent-before-render (obj page-obj)
+ (:documentation "Method called by the framework before the rendering phase. It is intended to be eventually overridden in descendant classes.
+ - OBJ is the tag instance
+ - PAGE-OBJ the page instance"))
+
+(defgeneric wcomponent-after-render (obj page-obj)
+ (:documentation "Method called by the framework after the rendering phase. It is intended to be eventually overridden in descendant classes.
+ - OBJ is the tag instance
+ - PAGE-OBJ the page instance"))
+
+(defvar *clawserver-base-path* nil)
+
+(defvar *html-4.01-strict* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">" "Page doctype as HTML 4.01 STRICT")
+
+(defvar *html-4.01-transitional* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">" "Page doctype as HTML 4.01 TRANSITIONAL")
+
+(defvar *html-4.01-frameset* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Frameset//EN\" \"http://www.w3.org/TR/html4/frameset.dtd\">" "Page doctype as HTML 4.01 FRAMESET")
+
+(defvar *xhtml-1.0-strict* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" "Page doctype as HTML 4.01 XHTML")
+
+(defvar *xhtml-1.0-transitional* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">" "Page doctype as XHTML 4.01 TRANSITIONAL")
+
+(defvar *xhtml-1.0-frameset* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Frameset//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd\">" "Page doctype as XHTML 4.01 FRAMESET")
+
+(defvar *default-encoding* "UTF-8" "Page default encoding (if no changes 'UTF-8')")
+
+(defvar *rewind-parameter* "rewindobject" "The request parameter for the object asking for a rewind action")
+
+(defvar *empty-tags*
+ (list "area" "base" "basefont" "br" "col" "frame"
+ "hr" "img" "input" "isindex" "meta"
+ "param" "link"))
+
+(defun request-id-table-map ()
+ "Holds an hash table of used components/tags id as keys and the number of their occurrences as values.
+So if you have a :id \"compId\" given to a previous component, the second
+time this id will be used, it will be rendered as \"compId1\", the third time will be \"compId2\" and so on"
+ (when (boundp '*request*)
+ (let ((id-table-map (aux-request-value :id-table-map)))
+ (if (null id-table-map)
+ (progn
+ (setf (aux-request-value :id-table-map) (make-hash-table :test 'equal)))
+ id-table-map))))
+
+(defun reset-request-id-table-map ()
+ "This function resets the ID-TABLE-MAP built during the request cycle to handle id uniqueness.
+See REQUEST-ID-TABLE-MAP for more info."
+ (when (boundp '*request*)
+ (setf (aux-request-value :id-table-map) (make-hash-table :test 'equal))))
+
+
+(defun parse-htcomponent-function (function-body)
+ "This function parses attributes passed to a htcomponent creation function"
+ (let ((attributes)
+ (body))
+ (loop for last-elem = nil then elem
+ for elem in function-body
+ do (if (or (and (stringp last-elem) (stringp elem))
+ (and (null last-elem) (stringp elem))
+ (subtypep (type-of elem) 'htcomponent)
+ (and (evenp (length attributes)) (stringp elem))
+ body)
+ (push elem body)
+ (push elem attributes)))
+ (list (reverse attributes) (reverse body))))
+
+(defun generate-id (id)
+ "This function is very useful when having references to components id inside component body.
+When used with :STATIC-ID the generated id will be mantained as is, and rendered just like the :ID tag attribute."
+ (let* ((id-ht (request-id-table-map))
+ (client-id-index (gethash id id-ht 0))
+ (result))
+ (if (= 0 client-id-index)
+ (setf result id)
+ (setf result (format nil "~a~d" id client-id-index)))
+ (setf (gethash id id-ht) (1+ client-id-index))
+ result))
+
+(defun build-tagf (tag-name parent empty-p &rest rest)
+ "This function is used to create a tag object instance
+- TAG-NAME the a string tag name to create, for example \"span\"
+- PARENT the parent class. usually 'TAG
+- EMPTY-P determines if the tag must be rendered as an empty tag during the request cycle phase.
+- REST a list of attribute/value pairs and the component body"
+ (let* ((fbody (parse-htcomponent-function (flatten rest)))
+ (id-table-map (request-id-table-map))
+ (id (getf (first fbody) :id))
+ (static-id (getf (first fbody) :static-id))
+ (instance))
+ (unless (null static-id)
+ (remf (first fbody) :id)
+ (setf id nil))
+ (setf instance (make-instance parent
+ :empty empty-p
+ :name (string-downcase tag-name)
+ :attributes (first fbody)
+ :body (second fbody)))
+ (if (null static-id)
+ (unless (or (null id-table-map) (null id))
+ (setf (htcomponent-client-id instance)
+ (generate-id id)))
+ (setf (htcomponent-client-id instance) static-id))
+ instance))
+
+(defun generate-tagf (tag-name empty-p)
+ "Internal function that generates an htcomponent creation function from the component class name
+- TAG-NAME the symbol class name of the component
+- EMPTY-P determines if the tag must be rendered as an empty tag during the request cycle phase."
+ (setf (fdefinition (intern (format nil "~a>" (string-upcase tag-name))))
+ #'(lambda (&rest rest) (build-tagf tag-name 'tag empty-p rest))))
+
+
+;;;----------------------------------------------------------------
+
+
+
+(defclass page()
+ ((writer :initarg :writer
+ :accessor page-writer :documentation "The output stream for this page instance")
+ (lisplet :initarg :lisplet
+ :reader page-lisplet :documentation "The lisplet that owns this page instance")
+ (can-print :initform nil
+ :accessor page-can-print)
+ (script-files :initarg :script-files
+ :accessor page-script-files :documentation "Holds component class scripts files injected by components during the request cycle")
+ (stylesheet-files :initarg :stylesheet-files
+ :accessor page-stylesheet-files :documentation "Holds component class css files injected by components during the request cycle")
+ (class-initscripts :initarg :class-initscripts
+ :accessor page-class-initscripts :documentation "Holds component class javascript directives injected by components during the request cycle")
+ (instancee-initscripts :initarg :instance-initscripts
+ :accessor page-instance-initscripts :documentation "Holds component instance javascript directives injected by components during the request cycle")
+ (indent :initarg :indent
+ :accessor page-indent :documentation "Determine if the output must be indented or not")
+ (tabulator :initarg :tabulator
+ :accessor page-tabulator :documentation "Holds the indentation level")
+ (xmloutput :initarg :xmloutput
+ :accessor page-xmloutput :documentation "Determine if the page must be rendered as an XML")
+ (current-form :initform :nil
+ :accessor page-current-form :documentation "During the rewinding phase the form or the action-link whose action has been fired")
+ (content-type :initarg :doc-type
+ :accessor page-doc-type :documentation "The DOCUMENT TYPE of the page (default to HTML 4.01 STRICT)")
+ (lasttag :initform nil
+ :accessor page-lasttag :documentation "Last rendered tag. Needed for page output rendering")
+ (json-component-count :initarg :json-component-count
+ :accessor page-json-component-count :documentation "Need to render the json object after an xhr call.")
+ (request-parameters :initarg :request-parameters)
+ (url :initarg :url
+ :accessor page-url :documentation "The URL provided with this page instance"))
+ (:default-initargs :writer t
+ :script-files nil
+ :json-component-count 0
+ :stylesheet-files nil
+ :class-initscripts nil
+ :instance-initscripts nil
+ :indent t
+ :tabulator 0
+ :xmloutput nil
+ :doc-type *html-4.01-strict*
+ :request-parameters nil
+ :url nil)
+ (:documentation "A page object holds claw components to be rendered") )
+
+(defclass htcomponent ()
+ ;class for html tags
+ ((page :initarg :page
+ :reader htcomponent-page :documentation "The owner page")
+ (body :initarg :body
+ :accessor htcomponent-body :documentation "The tag body")
+ (client-id :initarg :client-id
+ :accessor htcomponent-client-id :documentation "The tag computed id if :ID war provided for the building function")
+ (attributes :initarg :attributes
+ :accessor htcomponent-attributes :documentation "The tag attributes")
+ (empty :initarg :empty
+ :accessor htcomponent-empty :documentation "Determine if the tag has to be rendered as an empty tag")
+ (script-files :initarg :script-files
+ :accessor htcomponent-script-files :documentation "Page injectable script files")
+ (stylesheet-files :initarg :stylesheet-files
+ :accessor htcomponent-stylesheet-files :documentation "Page injectable css files")
+ (class-initscripts :initarg :class-initscripts
+ :accessor htcomponent-class-initscripts :documentation "Page injectable javascript class derectives")
+ (instance-initscript :initarg :instance-initscript
+ :accessor htcomponent-instance-initscript :documentation "Page injectable javascript instance derectives"))
+ (:default-initargs :page nil
+ :body nil
+ :client-id nil
+ :attributes nil
+ :empty nil
+ :script-files nil
+ :stylesheet-files nil
+ :class-initscripts nil
+ :instance-initscript nil)
+ (:documentation "Base class for all other claw components"))
+
+(defclass tag (htcomponent)
+ ((name :initarg :name
+ :reader tag-name :documentation "The tag name to be rendered"))
+ (:default-initargs :name nil)
+ (:documentation "This class is used to render the most part of html tags"))
+
+(defclass htstring (htcomponent)
+ ((raw :initarg :raw
+ :accessor htstring-raw :documentation "Determines if the string content must be html escaped or not"))
+ (:default-initargs :raw nil)
+ (:documentation "Component needed to render strings"))
+
+(defmethod initialize-instance :after ((inst tag) &rest keys)
+ (let ((empty-p (getf keys :empty))
+ (body (getf keys :body)))
+ (when (and (not (null empty-p))
+ (not (null body)))
+ (error (format nil "This tag cannot have a body <~a> body: '~a'" (tag-name inst) body)))))
+
+(defun $> (value)
+ "Creates an escaping htstring component"
+ (make-instance 'htstring :body value))
+
+(defun $raw> (value)
+ "Creates a non escaping htstring component"
+ (make-instance 'htstring :body value :raw t))
+
+(defclass htscript (tag) ()
+ (:documentation "Creates a component for rendering a <script> tag"))
+
+(defun script> (&rest rest)
+ (build-tagf "script" 'htscript nil rest))
+
+(defclass htlink (tag) ()
+ (:documentation "Creates a component for rendering a <link> tag"))
+
+(defun link> (&rest rest)
+ (build-tagf "link" 'htlink t rest))
+
+(defclass htbody (tag) ()
+ (:documentation "Creates a component for rendering a <body> tag"))
+
+(defun body> (&rest rest)
+ (build-tagf "body" 'htbody nil rest))
+
+(defclass hthead (tag) ()
+ (:documentation "Creates a component for rendering a <head> tag"))
+
+(defun head> (&rest rest)
+ (build-tagf "head" 'hthead nil rest))
+
+(mapcar #'(lambda (tag-name) (generate-tagf tag-name t))
+ ;;Creates empty tag initialization functions. But the ones directly defined
+ '("area" "base" "basefont" "br" "col" "frame"
+ "hr" "img" "input" "isindex" "meta"
+ "param"))
+
+(mapcar #'(lambda (tag-name) (generate-tagf tag-name nil))
+ ;;Creates non empty tag initialization functions. But the ones directly defined
+ '("a" "abbr" "acronym" "address" "applet"
+ "b" "bdo" "big" "blockquote" "button"
+ "caption" "center" "cite" "code" "colgroup"
+ "dd" "del" "dfn" "dir" "div" "dl" "dt"
+ "em"
+ "fieldset" "font" "form" "frameset"
+ "h1" "h2" "h3" "h4" "h5" "h6" "html"
+ "i" "iframe" "ins"
+ "kbd"
+ "label" "legend" "li"
+ "map" "menu"
+ "noframes" "noscript"
+ "object" "ol" "optgroup" "option"
+ "p" "pre"
+ "q"
+ "s" "samp" "select" "small" "span" "strike" "strong" "style" "sub" "sup"
+ "table" "tbody" "td" "textarea" "tfoot" "th" "thead" "title" "tr" "tt"
+ "u" "ul" "var"))
+
+(defun tag-empty-p (tag-name)
+ "Returns if a tag defined by the string TAG-NAME is empty"
+ (member tag-name *empty-tags* :test #'string-equal))
+
+(defun tag-symbol-class (tag-name)
+ "Returns the symbol class for a given TAG-NAME"
+ (let ((name (string-downcase tag-name)))
+ (cond ((string= name "script") 'htscript)
+ ((string= name "link") 'htlink)
+ ((string= name "body") 'htbody)
+ ((string= name "head") 'hthead)
+ (t 'tag))))
+;;;--------------------METHODS implementation----------------------------------------------
+
+(defmethod (setf htcomponent-page) ((pobj page) (obj htcomponent))
+ (let ((id (getf (htcomponent-attributes obj) :id))
+ (static-id (getf (htcomponent-attributes obj) :static-id)))
+ (setf (slot-value obj 'page) pobj)
+ (unless (and (null id) (null static-id))
+ (let ((client-id (htcomponent-client-id obj)))
+ (when (null client-id)
+ (if (null static-id)
+ (setf (htcomponent-client-id obj) (generate-id id))
+ (setf (htcomponent-client-id obj) static-id)))))))
+
+(defmethod page-request-parameters ((pobj page))
+ (if (and (boundp '*request*) (null (slot-value pobj 'request-parameters)))
+ (let ((parameters (append (post-parameters) (get-parameters)))
+ (pparameters (make-hash-table :test 'equal)))
+ (loop for kv in parameters
+ do (setf (gethash (string-upcase (car kv)) pparameters)
+ (append (gethash (string-upcase (car kv)) pparameters)
+ (list (cdr kv)))))
+ (setf (slot-value pobj 'request-parameters) pparameters))
+ (slot-value pobj 'request-parameters)))
+
+(defmethod page-req-parameter ((pobj page) name &optional as-list)
+ (let ((parameters (page-request-parameters pobj))
+ (retval))
+ (unless (null parameters)
+ (setf retval (gethash (string-upcase name) parameters))
+ (if (or (null retval) as-list)
+ retval
+ (first retval)))))
+
+(defmethod page-format ((obj page) str &rest rest)
+ (let ((json-p (page-json-id-list obj))
+ (writer (page-writer obj)))
+ (if (null json-p)
+ (apply #'format writer str rest)
+ (apply #'format writer (list
+ (regex-replace-all "\""
+ (regex-replace-all "\\\\\""
+ (regex-replace-all "\\n"
+ (apply #'format nil str rest)
+ "\\n")
+ "\\\\\\\"")
+ "\\\""))))))
+
+(defmethod page-format-raw ((obj page) str &rest rest)
+ (let ((writer (page-writer obj)))
+ (apply #'format writer str rest)))
+
+(defmethod page-json-id-list ((obj page))
+ (page-req-parameter obj "json" t))
+
+(defmethod page-init ((obj page))
+ (progn
+ (reset-request-id-table-map)
+ (setf (page-can-print obj) (null (page-json-id-list obj)))
+ (reset-request-id-table-map)
+ (setf (page-tabulator obj) 0)))
+
+(defmethod page-render-headings ((obj page))
+ (let* ((writer (page-writer obj))
+ (json-p (page-json-id-list obj))
+ (encoding (handler-case (format nil "~a" (stream-external-format writer))
+ (error () (format nil "~a" *default-encoding*))))
+ (xml-p (page-xmloutput obj))
+ (content-type (page-doc-type obj)))
+ (when (null json-p)
+ (unless (null xml-p)
+ (page-format-raw obj "<?xml version=\"1.0\" encoding=\"~a\"?>~%" encoding))
+ (unless (null content-type)
+ (page-format-raw obj "~a~%" content-type)))))
+
+(defmethod page-render ((obj page))
+ (let ((body (page-content obj))
+ (json-p (page-json-id-list obj)))
+ (if (null body)
+ (format nil "null body for page ~a~%" (type-of obj))
+ (progn
+ (page-init obj)
+ (unless (null (page-req-parameter obj *rewind-parameter*))
+ (htcomponent-rewind body obj))
+ (page-init obj)
+ (htcomponent-prerender (page-content obj) obj) ;Here we need a fresh new body!!!
+ (page-render-headings obj)
+ (page-init obj)
+ (unless (null json-p)
+ (page-format-raw obj "{components:{"))
+ (htcomponent-render (page-content obj) obj) ;Here we need a fresh new body!!!
+ (unless (null json-p)
+ (page-format-raw obj "},classInjections:\"")
+ (setf (page-can-print obj) t)
+ (dolist (injection (page-init-injections obj))
+ (htcomponent-render injection obj))
+ (page-format-raw obj "\",instanceInjections:\"")
+ (htcomponent-render (htbody-init-scripts-tag obj) obj)
+ (page-format-raw obj "\"}"))))))
+
+(defmethod page-body-init-scripts ((pobj page))
+ (let ((js-body ""))
+ (dolist (current-js (reverse (page-instance-initscripts pobj)))
+ (setf js-body (format nil "~a~%~a~%" js-body current-js)))
+ (if (string= "" js-body)
+ js-body
+ (format nil "~a" js-body))))
+
+(defmethod page-print-tabulation ((obj page))
+ (let ((json-p (page-json-id-list obj))
+ (tabulator (page-tabulator obj))
+ (indent-p (page-indent obj)))
+ (when (and (<= 0 tabulator) indent-p (null json-p))
+ (page-format-raw obj "~a"
+ (make-string tabulator :initial-element #\tab)))))
+
+(defmethod page-newline ((obj page))
+ (let ((json-p (page-json-id-list obj))
+ (indent-p (page-indent obj)))
+ (when (and indent-p (null json-p))
+ (page-format-raw obj "~%"))))
+
+(defmethod page-init-injections ((pobj page))
+ (let ((tag-list)
+ (class-init-scripts ""))
+
+ (dolist (script (reverse (page-class-initscripts pobj)))
+ (setf class-init-scripts (format nil "~a~%~a"
+ class-init-scripts
+ script)))
+ (unless (string= "" class-init-scripts)
+ (let ((current-js (script> :type "text/javascript")))
+ (setf (htcomponent-body current-js) class-init-scripts)
+ (push current-js tag-list)))
+
+ (dolist (js-file (page-script-files pobj))
+ (let ((current-js (script> :type "text/javascript" :src "")))
+ (setf (getf (htcomponent-attributes current-js) :src) js-file)
+ (push current-js tag-list)))
+
+ (dolist (css-file (page-stylesheet-files pobj))
+ (let ((current-css (link> :rel "stylesheet" :type "text/css" :href "")))
+ (setf (getf (htcomponent-attributes current-css) :href) css-file)
+ (push current-css tag-list)))
+
+ tag-list))
+
+;;;========= HTCOMPONENT ============================
+(defmethod htcomponent-can-print ((obj htcomponent))
+ (let* ((id (htcomponent-client-id obj))
+ (pobj (htcomponent-page obj))
+ (print-status (page-can-print pobj))
+ (render-p (member id (page-json-id-list pobj) :test #'string=)))
+ (or print-status render-p)))
+
+(defmethod htcomponent-json-print-start-component ((obj htcomponent))
+ (let* ((pobj (htcomponent-page obj))
+ (json-p (page-json-id-list pobj))
+ (id (htcomponent-client-id obj)))
+ (unless (or (null json-p) (null (member id json-p :test #'string-equal)))
+ (when (> (page-json-component-count pobj) 0)
+ (page-format pobj ","))
+ (page-format-raw pobj "~a:\"" id)
+ (incf (page-json-component-count pobj)))))
+
+(defmethod htcomponent-json-print-end-component ((obj htcomponent))
+ (let* ((pobj (htcomponent-page obj))
+ (json-p (page-json-id-list pobj))
+ (id (htcomponent-client-id obj)))
+ (unless (or (null json-p) (null (member id json-p :test #'string-equal)))
+ (page-format-raw pobj "\""))))
+
+(defmethod htcomponent-rewind :before ((obj htcomponent) (pobj page))
+ (setf (htcomponent-page obj) pobj))
+(defmethod htcomponent-prerender :before ((obj htcomponent) (pobj page))
+ (setf (htcomponent-page obj) pobj))
+(defmethod htcomponent-render :before ((obj htcomponent) (pobj page))
+ (setf (htcomponent-page obj) pobj))
+
+(defmethod htcomponent-rewind ((obj htcomponent) (pobj page))
+ (dolist (tag (htcomponent-body obj))
+ (when (subtypep (type-of tag) 'htcomponent)
+ (htcomponent-rewind tag pobj))))
+
+(defmethod htcomponent-prerender ((obj htcomponent) (pobj page))
+ (let ((previous-print-status (page-can-print pobj)))
+ (when (null previous-print-status)
+ (setf (page-can-print pobj) (htcomponent-can-print obj)))
+ (dolist (tag (htcomponent-body obj))
+ (when (subtypep (type-of tag) 'htcomponent)
+ (htcomponent-prerender tag pobj)))
+ (when (null previous-print-status)
+ (setf (page-can-print pobj) nil))))
+
+(defmethod htcomponent-render ((obj htcomponent) (pobj page))
+ (let ((body-list (htcomponent-body obj))
+ (previous-print-status (page-can-print pobj)))
+ (when (null previous-print-status)
+ (setf (page-can-print pobj) (htcomponent-can-print obj))
+ (htcomponent-json-print-start-component obj))
+ (dolist (tag body-list)
+ (if (stringp tag)
+ (htcomponent-render ($> tag) pobj)
+ (htcomponent-render tag pobj)))
+ (when (null previous-print-status)
+ (setf (page-can-print pobj) nil)
+ (htcomponent-json-print-end-component obj))))
+
+;;;========= TAG =====================================
+(defmethod tag-render-attributes ((obj tag) (pobj page))
+ (unless (null (htcomponent-attributes obj))
+ (loop for (k v) on (htcomponent-attributes obj) by #'cddr
+ do (progn
+ (assert (keywordp k))
+ (unless (null v)
+ (page-format pobj " ~a=\"~a\""
+ (string-downcase (if (eq k :static-id)
+ "id"
+ (symbol-name k)))
+ (let ((s (if (eq k :id)
+ (prin1-to-string (htcomponent-client-id obj))
+ (prin1-to-string v)))) ;escapes double quotes
+ (subseq s 1 (1- (length s))))))))))
+
+(defmethod tag-render-starttag ((obj tag) (pobj page))
+ (let ((tagname (tag-name obj))
+ (empty-p (htcomponent-empty obj))
+ (xml-p (page-xmloutput pobj)))
+ (setf (page-lasttag pobj) tagname)
+ (page-newline pobj)
+ (page-print-tabulation pobj)
+ (page-format pobj "<~a" tagname)
+ (tag-render-attributes obj pobj)
+ (if (null empty-p)
+ (progn
+ (page-format pobj ">")
+ (incf (page-tabulator pobj)))
+ (if (null xml-p)
+ (page-format pobj ">")
+ (page-format pobj "/>")))))
+
+(defmethod tag-render-endtag ((obj tag) (pobj page))
+ (let ((tagname (tag-name obj))
+ (previous-tagname (page-lasttag pobj))
+ (empty-p (htcomponent-empty obj)))
+ (when (null empty-p)
+ (progn
+ (decf (page-tabulator pobj))
+ (if (string= tagname previous-tagname)
+ (progn
+ (page-format pobj "</~a>" tagname))
+ (progn
+ (page-newline pobj)
+ (page-print-tabulation pobj)
+ (page-format pobj "</~a>" tagname)))))
+ (setf (page-lasttag pobj) nil)))
+
+(defmethod htcomponent-render ((obj tag) (pobj page))
+ (let ((body-list (htcomponent-body obj))
+ (previous-print-status (page-can-print pobj)))
+ (when (null previous-print-status)
+ (setf (page-can-print pobj) (htcomponent-can-print obj))
+ (htcomponent-json-print-start-component obj))
+ (unless (or (null (page-can-print pobj)) (null previous-print-status))
+ (tag-render-starttag obj pobj))
+ (dolist (tag body-list)
+ (if (stringp tag)
+ (htcomponent-render ($> tag) pobj)
+ (htcomponent-render tag pobj)))
+ (unless (or (null (page-can-print pobj)) (null previous-print-status))
+ (tag-render-endtag obj pobj))
+ (when (null previous-print-status)
+ (setf (page-can-print pobj) nil)
+ (htcomponent-json-print-end-component obj))))
+
+;;;========= HTHEAD ======================================
+(defmethod htcomponent-render ((obj hthead) (pobj page))
+ (when (null (page-json-id-list pobj))
+ (let ((body-list (htcomponent-body obj))
+ (injections (page-init-injections pobj)))
+ (tag-render-starttag obj pobj)
+ (dolist (tag body-list)
+ (if (stringp tag)
+ (htcomponent-render ($> tag) pobj)
+ (htcomponent-render tag pobj)))
+ (dolist (injection injections)
+ (htcomponent-render injection pobj))
+ (tag-render-endtag obj pobj))))
+
+;;;========= HTSTRING ===================================
+
+(defmethod htcomponent-rewind((obj htstring) (pobj page)))
+(defmethod htcomponent-prerender((obj htstring) (pobj page)))
+
+(defmethod htcomponent-render ((obj htstring) (pobj page))
+ (let ((body (htcomponent-body obj))
+ (json-p (not (null (page-json-id-list pobj))))
+ (print-p (page-can-print pobj)))
+ (unless (or (null print-p) (null body))
+ (unless (null json-p)
+ (setf body (regex-replace-all "\""
+ (regex-replace-all "\\\\\""
+ (regex-replace-all "\\n"
+ body
+ "\\n")
+ "\\\\\\\"")
+ "\\\"")))
+ (if (null (htstring-raw obj))
+ (loop for ch across body
+ do (case ch
+ ((#\<) (page-format-raw pobj "<"))
+ ((#\>) (page-format-raw pobj ">"))
+ ((#\&) (page-format-raw pobj "&"))
+ (t (page-format-raw pobj "~a" ch))))
+ (page-format-raw pobj body)))))
+
+;;;========= HTSCRIPT ===================================
+(defmethod htcomponent-prerender((obj htscript) (pobj page)))
+
+(defmethod htcomponent-render ((obj htscript) (pobj page))
+ (let ((xml-p (page-xmloutput pobj))
+ (body (htcomponent-body obj))
+ (previous-print-status (page-can-print pobj)))
+ (when (null previous-print-status)
+ (setf (page-can-print pobj) (htcomponent-can-print obj))
+ (htcomponent-json-print-start-component obj))
+ (unless (getf (htcomponent-attributes obj) :type)
+ (append '(:type "text/javascript") (htcomponent-attributes obj)))
+ (unless (null (page-can-print pobj))
+ (tag-render-starttag obj pobj)
+ (when (and (null (getf (htcomponent-attributes obj) :src))
+ (not (null (htcomponent-body obj))))
+ (if (null xml-p)
+ (page-format pobj "~%//<!--~%")
+ (page-format pobj "~%//<[CDATA[~%"))
+ (unless (listp body)
+ (setf body (list body)))
+ (dolist (element body)
+ (if (stringp element)
+ (htcomponent-render ($raw> element) pobj)
+ (htcomponent-render element pobj)))
+ (if (null xml-p)
+ (page-format pobj "~%//-->")
+ (page-format pobj "~%//]]>")))
+ (setf (page-lasttag pobj) nil)
+ (tag-render-endtag obj pobj))
+ (when (null previous-print-status)
+ (setf (page-can-print pobj) nil)
+ (htcomponent-json-print-end-component obj))))
+
+;;;========= HTLINK ====================================
+
+(defmethod htcomponent-render ((obj htlink) (pobj page))
+ (let ((previous-print-status (page-can-print pobj)))
+ (when (null previous-print-status)
+ (setf (page-can-print pobj) (htcomponent-can-print obj))
+ (htcomponent-json-print-start-component obj))
+ (unless (null (page-can-print pobj))
+ (unless (getf (htcomponent-attributes obj) :type)
+ (append '(:type "text/css") (htcomponent-attributes obj)))
+ (unless (getf (htcomponent-attributes obj) :rel)
+ (append '(:rel "styleshhet") (htcomponent-attributes obj)))
+ (tag-render-starttag obj pobj)
+ (tag-render-endtag obj pobj))
+ (when (null previous-print-status)
+ (setf (page-can-print pobj) nil)
+ (htcomponent-json-print-end-component obj))))
+
+;;;========= HTBODY ===================================
+(defmethod htcomponent-render ((obj htbody) (pobj page))
+ (let ((body-list (htcomponent-body obj))
+ (previous-print-status (page-can-print pobj)))
+ (unless (or (null (page-can-print pobj)) (null previous-print-status))
+ (setf (page-can-print pobj) (htcomponent-can-print obj))
+ (htcomponent-json-print-start-component obj))
+ (unless (null (page-can-print pobj))
+ (tag-render-starttag obj pobj))
+ (dolist (tag body-list)
+ (if (stringp tag)
+ (htcomponent-render ($> tag) pobj)
+ (htcomponent-render tag pobj)))
+ (unless (null (page-can-print pobj))
+ (htcomponent-render (htbody-init-scripts-tag pobj) pobj)
+ (tag-render-endtag obj pobj))
+ (unless (or (null (page-can-print pobj)) (null previous-print-status))
+ (setf (page-can-print pobj) nil)
+ (htcomponent-json-print-end-component obj))))
+
+(defmethod htbody-init-scripts-tag ((pobj page))
+ (let ((js (script> :type "text/javascript")))
+ (setf (htcomponent-page js) pobj)
+ (setf (htcomponent-body js) (page-body-init-scripts pobj))
+ js))
+
+;;;========= WCOMPONENT ===================================
+(defclass wcomponent (htcomponent)
+ ((parameters :initarg :parameters
+ :accessor wcomponent-parameters
+ :type cons
+ :documentation "must be a plist or nil")
+ (reserved-parameters :initarg :reserved-parameters
+ :accessor wcomponent-reserved-parameters
+ :type cons :documentation "Parameters that may not be used in the constructor function")
+ (informal-parameters :initarg :informal-parameters
+ :accessor wcomponent-informal-parameters
+ :type cons :documentation "Informal parameters are parameters optional for the component")
+ (allow-informal-parameters :initarg :allow-informal-parameters
+ :reader wcomponent-allow-informal-parametersp
+ :allocation :class :documentation "Determines if the component accepts informal parameters")
+ (template :initform nil
+ :accessor wcomponent-template
+ :type htcomponent :documentation "The component template. What gives to each wcomponent its unique aspect and features"))
+ (:default-initargs :informal-parameters nil
+ :reserved-parameters nil
+ :parameters nil
+ :allow-informal-parameters t)
+ (:documentation "Base class for creationg customized web components. Use this or one of its subclasses to make your own."))
+
+(defmethod wcomponent-check-parameters((comp wcomponent))
+ (let ((id nil)
+ (static-id nil))
+ (loop for (k v) on (htcomponent-attributes comp) by #'cddr
+ do (progn (when (and (eql v ':required) (not (eq k :id)))
+ (error (format nil
+ "Parameter ~a of class ~a is required"
+ k (class-name (class-of comp)))))
+ (when (eq k :id)
+ (setf id v))
+ (when (eq k :static-id)
+ (setf static-id v))))
+ (when (and (eq id :required) (null static-id))
+ (error (format nil
+ "Parameter id of class ~a is required"
+ (class-name (class-of comp)))))))
+
+
+(defun make-component (name parameters content)
+ (let ((instance (make-instance name))
+ (static-id (getf parameters :static-id)))
+ (unless (null static-id)
+ (remf parameters :id))
+ (loop for (k v) on parameters by #'cddr
+ do (let ((keyword k))
+ (when (eq keyword :static-id)
+ (setf keyword :id))
+ (multiple-value-bind (inst-k inst-v inst-p)
+ (get-properties (wcomponent-parameters instance) (list keyword))
+ (declare (ignore inst-v))
+ (unless (null (find inst-k (wcomponent-reserved-parameters instance)))
+ (error (format nil "Parameter ~a is reserved" inst-k)))
+ (if (null inst-p)
+ (if (null (wcomponent-allow-informal-parametersp instance))
+ (error (format nil
+ "Component ~a doesn't accept informal parameters"
+ name))
+ (setf (getf (wcomponent-informal-parameters instance) keyword) v))
+ (progn
+ (when (and (eq keyword :id) (not (null static-id)))
+ (setf keyword :static-id))
+ (setf (getf (htcomponent-attributes instance) keyword) v))))))
+ (wcomponent-check-parameters instance)
+ (let ((id (wcomponent-parameter-value instance :id))
+ (static-id (wcomponent-parameter-value instance :static-id)))
+ (if (and (null static-id) id)
+ (setf (htcomponent-client-id instance) (generate-id id))
+ (setf (htcomponent-client-id instance) static-id)))
+ (setf (htcomponent-body instance) content)
+ instance))
+
+(defun build-component (component-name &rest rest)
+ (let ((fbody (parse-htcomponent-function (flatten rest))))
+ (make-component component-name (first fbody) (second fbody))))
+
+
+(defmethod wcomponent-parameter-value ((c wcomponent) key)
+ (let ((result (getf (htcomponent-attributes c) key :undefined)))
+ (if (eq result :undefined)
+ (getf (wcomponent-parameters c) key)
+ result)))
+
+(defmacro defcomponent (name superclass-name slot-specifier &body class-option)
+ (let ((symbolf (intern (format nil "~a>" name))))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defclass ,name
+ ,@(if (null superclass-name)
+ (list '(wcomponent))
+ (list
+ (let ((result))
+ (dolist (parent superclass-name)
+ (when (subtypep parent 'wcomponent)
+ (setf result t)))
+ (if result
+ superclass-name
+ (append '(wcomponent) superclass-name)))))
+ ,@(if (null class-option)
+ (list slot-specifier)
+ (push slot-specifier class-option)))
+ (setf (fdefinition `,',symbolf) #'(lambda(&rest rest) (build-component ',name rest))))))
+
+
+(defmethod htcomponent-rewind ((obj wcomponent) (pobj page))
+ (let ((template (wcomponent-template obj)))
+ (wcomponent-before-rewind obj pobj)
+ (if (listp template)
+ (dolist (tag template)
+ (htcomponent-rewind tag pobj))
+ (htcomponent-rewind template pobj))
+ (wcomponent-after-rewind obj pobj)))
+
+(defmethod wcomponent-before-rewind ((obj wcomponent) (pobj page)))
+(defmethod wcomponent-after-rewind ((obj wcomponent) (pobj page)))
+
+(defmethod htcomponent-prerender ((obj wcomponent) (pobj page))
+ (wcomponent-before-prerender obj pobj)
+ (let ((previous-print-status (page-can-print pobj))
+ (template (wcomponent-template obj)))
+ (when (null previous-print-status)
+ (setf (page-can-print pobj) (htcomponent-can-print obj)))
+ (unless (null (page-can-print pobj))
+ (dolist (script (htcomponent-script-files obj))
+ (pushnew script (page-script-files pobj) :test #'equal))
+ (dolist (css (htcomponent-stylesheet-files obj))
+ (pushnew css (page-stylesheet-files pobj) :test #'equal))
+ (dolist (js (htcomponent-class-initscripts obj))
+ (pushnew js (page-class-initscripts pobj) :test #'equal))
+ (unless (null (htcomponent-instance-initscript obj))
+ (pushnew (htcomponent-instance-initscript obj) (page-instance-initscripts pobj) :test #'equal)))
+ (if (listp template)
+ (dolist (tag template)
+ (when (subtypep (type-of tag) 'htcomponent)
+ (htcomponent-prerender tag pobj)))
+ (htcomponent-prerender template pobj))
+ (when (null previous-print-status)
+ (setf (page-can-print pobj) nil)))
+ (wcomponent-after-prerender obj pobj))
+
+(defmethod wcomponent-before-prerender ((obj wcomponent) (pobj page)))
+(defmethod wcomponent-after-prerender ((obj wcomponent) (pobj page)))
+
+(defmethod htcomponent-render ((obj wcomponent) (pobj page))
+ (let ((template (wcomponent-template obj))
+ (previous-print-status (page-can-print pobj)))
+ (when (null previous-print-status)
+ (setf (page-can-print pobj) (htcomponent-can-print obj))
+ (htcomponent-json-print-start-component obj))
+ (wcomponent-before-render obj pobj)
+ (unless (listp template)
+ (setf template (list template)))
+ (dolist (tag template)
+ (if (stringp tag)
+ (htcomponent-render ($> tag) pobj)
+ (htcomponent-render tag pobj)))
+ (wcomponent-after-render obj pobj)
+ (when (null previous-print-status)
+ (setf (page-can-print pobj) nil)
+ (htcomponent-json-print-end-component obj))))
+
+(defmethod wcomponent-before-render ((obj wcomponent) (pobj page)))
+(defmethod wcomponent-after-render ((obj wcomponent) (pobj page)))
Added: trunk/main/claw-core/tests/packages.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-core/tests/packages.lisp Tue Jan 22 01:44:06 2008
@@ -0,0 +1,35 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: tests/packages.lisp $
+
+;;; Copyright (c) 2008, Andrea Chiumenti. 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 :claw-tests
+ (:use :cl :claw :hunchentoot)
+ (:export :claw-tst-start
+ :claw-tst-stop))
\ No newline at end of file
Added: trunk/main/claw-core/tests/test1.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-core/tests/test1.lisp Tue Jan 22 01:44:06 2008
@@ -0,0 +1,220 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: tests/test1.lisp $
+
+;;; Copyright (c) 2008, Andrea Chiumenti. 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 :claw-tests)
+
+
+(setf *clawserver-base-path* "/claw")
+
+(defvar *test-lisplet*)
+(setf *test-lisplet* (make-instance 'lisplet :realm "test1" :base-path "/test"))
+
+(defvar *test-lisplet2*)
+(setf *test-lisplet2* (make-instance 'lisplet :realm "test2" :base-path "/test2"))
+
+
+
+(defparameter *clawserver* (make-instance 'clawserver :port 4242))
+;;;(defparameter *clawserver* (make-instance 'clawserver :port 4242 :sslport 4445
+;;; :ssl-certificate-file #P"/home/kiuma/pem/cacert.pem"
+;;; :ssl-privatekey-file #P"/home/kiuma/pem/privkey.pem"))
+
+(clawserver-register-lisplet *clawserver* *test-lisplet*)
+(clawserver-register-lisplet *clawserver* *test-lisplet2*)
+
+(defun claw-tst-start ()
+ (clawserver-start *clawserver*))
+
+(defun claw-tst-stop ()
+ (clawserver-stop *clawserver*))
+
+
+;;;--------------------template--------------------------------
+
+(defcomponent site-template () ())
+
+(defmethod wcomponent-parameters ((o site-template))
+ (list :title :required))
+
+(defmethod wcomponent-template ((o site-template))
+ (html>
+ (head>
+ (title>
+ (wcomponent-parameter-value o ':title)))
+ (body>
+ (wcomponent-informal-parameters o)
+ (p>
+ (a> :href "/claw/test/index.html"))
+ (htcomponent-body o))))
+
+
+;;;--------------------index testing page--------------------------------
+(defclass index-page (page) ())
+
+(defmethod page-content ((o index-page))
+ (site-template> :title "Home test page"
+ (p> :id "p"
+ (ul>
+ (li> (a> :href "http://www.gentoo.org" :target "gentoo"
+ "gentoo"))
+ (li> (a> :href "../test/realm.html" :target "clwo1"
+ "realm on lisplet 'test'"))
+ (li> (a> :href "../test2/realm.html" :target "clwo2"
+ "realm on lisplet 'test2'"))
+ (li> (a> :href "id-tests.html" "id generation test"))
+ (li> (a> :href "form.html" ($> "form components test")))))))
+
+(lisplet-register-page-location *test-lisplet* 'index-page "index.html" t)
+
+;;;--------------------realm test page--------------------------------
+(defclass realm-page (page) ())
+
+(defmethod page-content ((o realm-page))
+ (let ((lisplet (page-lisplet o)))
+ (when (or (null *session*) (not (string= (session-realm *session*) (lisplet-realm lisplet))))
+ (progn
+ (start-session (format nil "~@[~a~]~a/" *clawserver-base-path* (lisplet-base-path (page-lisplet o))))
+ (setf (session-value 'RND-NUMBER) (random 1000))))
+ (site-template> :title "Realm test page"
+ (p>
+ "session"
+ (ul>
+ (li> (a> :href "http://www.gentoo.org" :target "gentoo"
+ "gentoo"))
+ (li> (a> :href "../test/realm.html" :target "clwo1"
+ "realm on lisplet 'test'"))
+ (li> (a> :href "../test2/realm.html" :target "clwo2"
+ "realm on lisplet 'test2'"))
+ (li> "Rnd number value: " (format nil "~d" (session-value 'RND-NUMBER)))
+ (li> "Remote Addr: " (session-remote-addr *session*))
+ (li> "User agent: " (session-user-agent *session*))
+ (li> "Lisplet Realm: " (lisplet-realm (page-lisplet o)))
+ (li> "Session Realm: " (session-realm *session*))
+ (li> "Session value: " (format nil "~a" (hunchentoot::session-string *session*)))
+ (li> "Request Realm: " (hunchentoot::realm *request*)))))))
+
+(lisplet-register-page-location *test-lisplet* 'realm-page "realm.html")
+(lisplet-register-page-location *test-lisplet2* 'realm-page "realm.html")
+
+;;;--------------------id testing page--------------------------------
+(defclass id-tests-page (page) ())
+
+(defmethod page-content ((o id-tests-page))
+ (let ((uid (generate-id "uid"))
+ (uid2 (generate-id "uid")))
+ (site-template> :title "a page title"
+ "\"<escaping>test\""
+ (hr>)
+ (div> :id "foo" :class "goo"
+ :onclick "this.innerHTML = this.id"
+ "passed id: 'foo'[click me, to see generated id]")
+ (div> :id "foo"
+ :onclick "this.innerHTML = this.id"
+ "passed id: 'foo'[click me, to see generated id]")
+ (div> :static-id uid
+ :onclick "this.innerHTML = this.id"
+ "passed id: 'uid' (generated with generate-id)[click me, to see generated id]")
+ (div> :static-id uid2
+ :onclick "this.innerHTML = this.id"
+ "passed id: 'uid' (generated with generate-id)[click me, to see generated id]"))))
+
+(lisplet-register-page-location *test-lisplet* 'id-tests-page "id-tests.html")
+
+
+;;;--------------------from components testing page--------------------------------
+(defclass form-page (page)
+ ((name :initarg :name
+ :accessor form-page-name)
+ (surname :initarg :surname
+ :accessor form-page-surname)
+ (gender :initarg :gender
+ :reader form-page-gender
+ :writer setf-gender)
+ (colors :initarg :colors
+ :accessor form-page-colors))
+
+ (:default-initargs :name "kiuma"
+ :surname "surnk"
+ :colors nil
+ :gender '("M")))
+
+(defmethod page-content ((o form-page))
+ (site-template> :title "a page title"
+ (cform> :id "testform" :method "post"
+ (table>
+ (tr>
+ (td> "Name")
+ (td>
+ (cinput> :id "name"
+ :type "text"
+ :accessor 'form-page-name)))
+ (tr>
+ (td> "Surname")
+ (td>
+ (cinput> :id "surname"
+ :type "text"
+ :accessor 'form-page-surname)))
+ (tr>
+ (td> "Gender")
+ (td>
+ (cselect> :id "gender"
+ :writer 'setf-gender
+ (loop for gender in (list "M" "F")
+ collect (option> :value gender
+ (when (string= gender (first (form-page-gender o)))
+ '(:selected "selected"))
+ (if (string= gender "M")
+ "Male"
+ "Female"))))))
+ (tr>
+ (td> "Colors")
+ (td>
+ (cselect> :id "colors"
+ :multiple "true"
+ :style "width:80px;height:120px;"
+ :accessor 'form-page-colors
+ (loop for color in (list "R" "G" "B")
+ collect (option> :value color
+ (when (member color (form-page-colors o) :test #'string=)
+ '(:selected "selected"))
+ (cond
+ ((string= color "R") "red")
+ ((string= color "G") "green")
+ (t "blue")))))))
+ (tr>
+ (td> :colspan "2"
+ (csubmit> :id "submit" :value "OK")))))
+ (div> (format nil "Name: ~a" (form-page-name o)))
+ (div> (format nil "Surname: ~a" (form-page-surname o)))
+ (div> (format nil "Gender: ~a" (first (form-page-gender o))))))
+
+(lisplet-register-page-location *test-lisplet* 'form-page "form.html")
+
+
+
More information about the Claw-cvs
mailing list