[claw-cvs] r66 - in trunk/main/claw-html: . src

25 Jul 2008

Author: achiumenti
Date: Fri Jul 25 11:09:52 2008
New Revision: 66

Added:
   trunk/main/claw-html/
   trunk/main/claw-html/claw-html.asd
   trunk/main/claw-html/src/
   trunk/main/claw-html/src/components.lisp
   trunk/main/claw-html/src/meta.lisp
   trunk/main/claw-html/src/packages.lisp
   trunk/main/claw-html/src/tags.lisp
   trunk/main/claw-html/src/translators.lisp
   trunk/main/claw-html/src/validators.lisp
Log:
claw html framework

Added: trunk/main/claw-html/claw-html.asd
==============================================================================

--- (empty file)
+++ trunk/main/claw-html/claw-html.asd	Fri Jul 25 11:09:52 2008
@@ -0,0 +1,50 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: claw-html.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-html
+  :name "claw-html"
+  :author "Andrea Chiumenti"
+  :description "Common Lisp Active Web HTML generator."
+  :depends-on (:closer-mop :local-time :parenscript :cl-ppcre :split-sequence)
+  :components ((:module src
+                        :components ((:file "packages")
+                                     ;(:file "mime-type" :depends-on ("packages"))
+                                     ;(:file "misc" :depends-on ("mime-type"))
+                                     ;:(:file "i18n" :depends-on ("packages"))
+                                     ;(:file "locales" :depends-on ("i18n"))
+                                     ;(:file "connector" :depends-on ("misc"))
+                                     ;(:file "logger" :depends-on ("misc"))
+                                     ;(:file "session-manager" :depends-on ("misc"))
+                                     (:file "tags" :depends-on ("packages"))
+                                     (:file "meta" :depends-on ("packages"))
+                                     (:file "components" :depends-on ("tags" "meta"))
+                                     (:file "validators" :depends-on ("components"))
+                                     (:file "translators" :depends-on ("validators"))))))
+                                     ;(:file "server" :depends-on ("components"))
+                                     ;(:file "lisplet" :depends-on ("server"))))))

Added: trunk/main/claw-html/src/components.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-html/src/components.lisp	Fri Jul 25 11:09:52 2008
@@ -0,0 +1,562 @@
+;;; -*- 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-html)
+
+(defvar *id-and-static-id-description* "- :ID The htcomponent-client-id value. CLAW can transform its value to make it univocal
+- :STATIC-ID Like the :ID parameter, it sets the htcomponent-client-id instance property, but CLAW will not manage its value to manage its univocity." "Description used for describing :ID and :STATIC-ID used in claw component init functions documentation
+")
+
+(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"))
+
+(defgeneric component-id-and-value (cinput &key from-request-p)
+  (:documentation "Returns the form component \(such as <input> and <select>) client-id and the associated value.
+When FROM-REQUEST-P is not null, the value is retrived from the http request by its name, from the associated reader or accessor when nil"))
+
+(defgeneric label (cinput)
+  (:documentation "Returns the label that describes the component. It's also be used when component validation fails. If it's a function it is funcalled"))
+
+(defgeneric name-attr (cinput)
+  (:documentation "Returns the name of the input component"))
+
+(defun component-validation-errors (component)
+  "Resurns possible validation errors occurred during form rewinding bound to a specific component"
+  (let ((client-id (htcomponent-client-id component)))
+    (getf *validation-errors* (intern client-id))))
+
+;--------------------------------------------------------------------------------
+
+
+
+(defclass _cform (wcomponent)
+    ((action :initarg :action
+	     :accessor action
+	     :documentation "Function performed after user submission")
+     (css-class :initarg :class
+		:reader css-class
+		:documentation "The html CLASS attribute")
+     (method :initarg :method
+             :reader form-method
+             :documentation "Form post method (may be \"get\" or \"post\")"))
+  (:default-initargs :action nil :class nil :method "post")
+  (:documentation "Internal use component"))
+
+(defmethod wcomponent-after-rewind ((obj _cform) (pobj page))
+  (let ((validation-errors *validation-errors*)
+	(action (action obj)))
+    (when (and (null validation-errors)
+               action
+               (cform-rewinding-p obj pobj))
+      (funcall action pobj))))
+
+(defmethod cform-rewinding-p ((cform _cform) (page page))
+  (string= (htcomponent-client-id cform)
+	   (page-req-parameter page *rewind-parameter*)))
+
+(defclass cform (_cform)
+  ((execut-p :initform T
+             :accessor cform-execute-p
+             :documentation "When nil the form will never rewind an the CFORM-REWINDING-P will always be nil"))
+  (:metaclass metacomponent)
+  (: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"))
+
+(let ((class (find-class 'cform)))
+  (closer-mop:ensure-finalized class)
+  (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
+	(format nil "Description: ~a~%Parameters:~%~a~a~%~%~a"
+		"Function that instantiates a CFORM component and renders a html <form> tag."
+		*id-and-static-id-description*
+		(describe-html-attributes-from-class-slot-initargs class)
+		(describe-component-behaviour class))))
+
+
+(defmethod wcomponent-template((cform cform))
+  (let ((client-id (htcomponent-client-id cform))
+	(class (css-class cform))
+        (method (form-method cform))
+	(validation-errors *validation-errors*))
+    (when validation-errors
+      (if (or (null class) (string= class ""))
+	  (setf class "error")
+	  (setf class (format nil "~a error" class))))
+    (form> :static-id client-id
+	   :class class
+           :method method
+	   (wcomponent-informal-parameters cform)
+	   (input> :name *rewind-parameter*
+		   :type "hidden"
+		   :value client-id)
+	   (htcomponent-body cform))))
+
+(defmethod cform-rewinding-p ((cform cform) (page page))
+  (and (cform-execute-p cform)
+       (string= (htcomponent-client-id cform)
+                (page-req-parameter page *rewind-parameter*))))
+
+(defmethod wcomponent-before-rewind ((obj cform) (pobj page))
+  (let ((render-condition (htcomponent-render-condition obj)))
+    (setf (cform-execute-p obj) (not (and render-condition (null (funcall render-condition))))
+          (page-current-form pobj) obj)))
+
+(defmethod wcomponent-after-rewind :after ((obj cform) (pobj page))
+  (setf (page-current-form pobj) nil))
+
+(defmethod wcomponent-before-prerender ((obj cform) (pobj page))
+  (setf (page-current-form pobj) obj))
+
+(defmethod wcomponent-after-prerender ((obj cform) (pobj page))
+  (setf (page-current-form pobj) nil))
+
+(defmethod wcomponent-before-render ((obj cform) (pobj page))
+  (setf (page-current-form pobj) obj))
+
+(defmethod wcomponent-after-render ((obj cform) (pobj page))
+  (setf (page-current-form pobj) nil))
+;--------------------------------------------------------------------------------
+
+(defclass action-link (_cform) ()
+  (:metaclass metacomponent)
+  (:default-initargs :reserved-parameters (list :href))
+  (:documentation "This component behaves like a CFORM, firing it's associated action once clicked.
+It renders as a normal link."))
+
+(let ((class (find-class 'action-link)))
+  (closer-mop:ensure-finalized class)
+  (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
+	(format nil "Description: ~a~%Parameters:~%~a~a~a~%~%~a"
+		"Instantiates an ACTION-LINK that renders an <a> link that cals a page method."
+		*id-and-static-id-description*
+		(describe-html-attributes-from-class-slot-initargs (find-class 'cform))
+		(describe-html-attributes-from-class-slot-initargs class)
+		(describe-component-behaviour class))))
+
+(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))))
+
+
+;---------------------------------------------------------------------------------------
+(defclass base-cinput (wcomponent)
+  ((result-as-list-p :initarg :multiple
+		   :accessor cinput-result-as-list-p
+		   :documentation "When not nil the associated request parameter will ba a list")
+   (writer :initarg :writer
+	   :reader cinput-writer
+	  :documentation "Visit object slot writer symbol, used to write the input value to the visit object")
+   (reader :initarg :reader
+	     :reader cinput-reader
+	     :documentation "Visit object slot reader symbol, used to get the corresponding value from the visit object")
+   (accessor :initarg :accessor
+	     :reader cinput-accessor
+	     :documentation "Visit object slot accessor symbol. It can be used in place of the :READER and :WRITER parameters")
+   (label :initarg :label
+	  :documentation "The label is the description of the component. It's also be used when component validation fails.")
+   (translator :initarg :translator
+	       :reader translator
+	       :documentation "A validator instance that encodes and decodes input values to and from the visit object mapped property")
+   (validator :initarg :validator
+	      :reader validator
+	      :documentation "A function that accept the passed component value during submission and performs the validation logic calling the validator functions.")
+   (visit-object :initarg :visit-object
+		 :reader cinput-visit-object
+		 :documentation "The object hoding the property mapped to the current input html component. When nil the owner page is used.")
+   (css-class :initarg :class
+	      :reader css-class
+	      :documentation "the html component class attribute"))
+  (:default-initargs :multiple nil :writer nil :reader nil :accessor nil :class nil
+		     :label nil :translator *simple-translator* :validator nil :visit-object nil)
+  (:documentation "Class inherited from both CINPUT and CSELECT"))
+
+(defmethod label ((cinput base-cinput))
+  (let ((label (slot-value cinput 'label)))
+    (if (functionp label)
+        (funcall label)
+        label)))
+
+(defmethod name-attr ((cinput base-cinput))
+  (htcomponent-client-id cinput))
+
+(defclass cinput (base-cinput)
+    ((input-type :initarg :type
+		:reader input-type
+		:documentation "The html <input> TYPE attribute. For submit type, use the CSUBMIT> function."))
+    (:metaclass metacomponent)
+    (:default-initargs :reserved-parameters (list :value :name) :empty t :type "text")
+    (:documentation "Request cycle aware component the renders as an INPUT tag class"))
+
+(let ((class (find-class 'cinput)))
+  (closer-mop:ensure-finalized class)
+  (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
+	(format nil "Description: ~a~%Parameters:~%~a~a~a~%~%~a"
+		"Function that instantiates a CINPUT component and renders a html <input> tag."
+		*id-and-static-id-description*
+		(describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput))
+		(describe-html-attributes-from-class-slot-initargs class)
+		(describe-component-behaviour class))))
+
+(defmethod wcomponent-template ((cinput cinput))
+  (let ((client-id (htcomponent-client-id cinput))
+	(type (input-type cinput))
+	(translator (translator cinput))
+	(value "")
+	(class (css-class cinput)))
+    (when (component-validation-errors cinput)
+      (if (or (null class) (string= class ""))
+	  (setf class "error")
+	  (setf class (format nil "~a error" class))))
+    (setf value (translator-encode translator cinput))
+    (input> :static-id client-id
+	    :type type
+	    :name (name-attr cinput)
+	    :class class
+	    :value value
+	    (wcomponent-informal-parameters cinput))))
+
+(defmethod wcomponent-after-rewind ((cinput base-cinput) (page page))
+  (when (cform-rewinding-p (page-current-form page) page)
+    (let ((visit-object (or (cinput-visit-object cinput) page))
+          (accessor (cinput-accessor cinput))
+          (writer (cinput-writer cinput))
+          (validator (validator cinput))
+          (value (translator-decode (translator cinput) cinput)))
+;      (log-message :info "********************* ~a : ~a" cinput value)
+      (unless (or (null value) (component-validation-errors cinput))
+	(when validator
+	  (funcall validator value))
+	(unless (component-validation-errors cinput)
+	  (if (and (null writer) accessor)
+	      (funcall (fdefinition `(setf ,accessor)) value visit-object)
+	      (funcall (fdefinition writer) value visit-object)))))))
+
+(defclass ctextarea (base-cinput)
+    ()
+    (:metaclass metacomponent)
+    (:default-initargs :reserved-parameters (list :name) :empty nil)
+    (:documentation "Request cycle aware component the renders as an INPUT tag class"))
+
+(let ((class (find-class 'ctextarea)))
+  (closer-mop:ensure-finalized class)
+  (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
+	(format nil "Description: ~a~%Parameters:~%~a~a~a~%~%~a"
+		"Function that instantiates a CTEXTAREA component and renders a html <textarea> tag."
+		*id-and-static-id-description*
+		(describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput))
+		(describe-html-attributes-from-class-slot-initargs class)
+		(describe-component-behaviour class))))
+
+(defmethod wcomponent-template ((ctextarea ctextarea))
+  (let ((client-id (htcomponent-client-id ctextarea))
+	(translator (translator ctextarea))
+	(value "")
+	(class (css-class ctextarea)))
+    (when (component-validation-errors ctextarea)
+      (if (or (null class) (string= class ""))
+	  (setf class "error")
+	  (setf class (format nil "~a error" class))))
+    (setf value (translator-encode translator ctextarea))
+    (textarea> :static-id client-id
+               :name (name-attr ctextarea)
+               :class class
+               (wcomponent-informal-parameters ctextarea)
+               (or value ""))))
+
+(defmethod component-id-and-value ((cinput base-cinput) &key (from-request-p t))
+  (let ((client-id (htcomponent-client-id cinput))
+	(visit-object (or (cinput-visit-object cinput) (htcomponent-page cinput)))
+	(accessor (cinput-accessor cinput))
+	(reader (cinput-reader cinput))
+	(result-as-list-p (cinput-result-as-list-p cinput))
+	(value ""))
+    (setf value
+	  (cond
+	    (from-request-p (page-req-parameter (htcomponent-page cinput)
+						(name-attr cinput)
+						result-as-list-p))
+	    ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
+	    (t (funcall (fdefinition reader) visit-object))))
+    (values client-id value)))
+
+;---------------------------------------------------------------------------------------
+(defclass cinput-file (cinput)
+    ()
+    (:metaclass metacomponent)
+    (:default-initargs :reserved-parameters (list :value :name :type) :empty t :type "file" :translator *file-translator*)
+    (:documentation "Request cycle aware component the renders as an INPUT tag class of type file"))
+
+(let ((class (find-class 'cinput-file)))
+  (closer-mop:ensure-finalized class)
+  (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
+	(format nil "Description: ~a~%Parameters:~%~{~a~}~%~%~a"
+		"Function that instantiates a CINPUT component and renders a html <input> tag of type \"file\"."
+                (list
+                 *id-and-static-id-description*
+                 (describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput))
+                 (describe-html-attributes-from-class-slot-initargs class))
+		(describe-component-behaviour class))))
+
+;---------------------------------------------------------------------------------------
+(defclass csubmit (_cform)
+    ((value :initarg :value
+	    :reader csubmit-value
+	    :documentation "The html VALUE attribute"))
+  (:metaclass metacomponent)
+  (:default-initargs :reserved-parameters (list :type :name) :empty t :action nil)
+  (:documentation "This component render as an INPUT tag class ot type submit, but
+can override the default CFORM action, using its own associated action"))
+
+(let ((class (find-class 'csubmit)))
+  (closer-mop:ensure-finalized class)
+  (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
+	(format nil "Description: ~a~%Parameters:~%~a~a~a~%~%~a"
+		"Function that instantiates a CSUBMIT component and renders a html <input> tag of submit type."
+		*id-and-static-id-description*
+		(describe-html-attributes-from-class-slot-initargs (find-class 'cform))
+		(describe-html-attributes-from-class-slot-initargs class)
+		(describe-component-behaviour class))))
+
+(defmethod name-attr ((csubmit csubmit))
+  (htcomponent-client-id csubmit))
+
+(defmethod wcomponent-template ((obj csubmit))
+  (let ((client-id (htcomponent-client-id obj))
+	(value (csubmit-value obj)))
+    (input> :static-id client-id
+	    :type "submit"
+	    :name (name-attr obj)
+	    :value value
+	    (wcomponent-informal-parameters obj))))
+
+(defmethod wcomponent-after-rewind ((obj csubmit) (pobj page))
+  (when (cform-rewinding-p (page-current-form pobj) pobj)
+    (let ((action (action obj))
+          (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 (action current-form) action)))))
+
+;-----------------------------------------------------------------------------
+(defclass submit-link (csubmit)
+    ()
+  (:metaclass metacomponent)
+  (:default-initargs :reserved-parameters (list :href) :empty nil)
+  (:documentation "This component renders as a normal link, but behaves like a CSUBMIT,
+so it can be used instead of CSUBMIT when needed"))
+
+(let ((class (find-class 'submit-link)))
+  (closer-mop:ensure-finalized class)
+  (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
+	(format nil "Description: ~a~%Parameters:~%~a~a~a~%~%~a"
+		"Function that instantiates a SUBMIT-LINK component and renders a html <a> tag that can submit the form where it is contained."
+		*id-and-static-id-description*
+		(describe-html-attributes-from-class-slot-initargs (find-class 'cform))
+		(describe-html-attributes-from-class-slot-initargs class)
+		(describe-component-behaviour class))))
+
+(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 (name-attr obj)
+	     :value "-")
+     (a> :static-id id
+	:href (format nil "javascript:document.getElementById('~a').click();" submit-id)
+	(wcomponent-informal-parameters obj)
+	(htcomponent-body obj)))))
+
+;--------------------------------------------------------------------------
+(defclass cselect (base-cinput) ()
+  (:default-initargs :reserved-parameters (list :type :name) :empty nil)
+  (:metaclass metacomponent)
+  (:documentation "This component renders as a normal SELECT tag class,
+but it is request cycle aware."))
+
+(let ((class (find-class 'cselect)))
+  (closer-mop:ensure-finalized class)
+  (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
+	(format nil "Description: ~a~%Parameters:~%~a~a~a~%~%~a"
+		"Function that instantiates a CSELECT component and renders a html <select> tag."
+		*id-and-static-id-description*
+		(describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput))
+		(describe-html-attributes-from-class-slot-initargs class)
+		(describe-component-behaviour class))))
+
+(defmethod wcomponent-template ((obj cselect))
+  (let ((client-id (htcomponent-client-id obj))
+	(class (css-class obj)))
+    (when (component-validation-errors obj)
+      (if (or (null class) (string= class ""))
+	  (setf class "error")
+	  (setf class (format nil "~a error" class))))
+    (select> :static-id client-id
+	     :name (name-attr obj)
+	     :class class
+	     :multiple (cinput-result-as-list-p obj)
+	     (wcomponent-informal-parameters obj)
+	     (htcomponent-body obj))))
+
+;--------------------------------------------------------------------------------------------
+
+(defclass ccheckbox (cinput)
+    ((test :initarg :test
+             :accessor ccheckbox-test)
+     (value :initarg :value
+            :accessor ccheckbox-value))
+    (:metaclass metacomponent)
+    (:default-initargs :reserved-parameters (list :name) :empty t :type "checkbox" :test #'equal)
+    (:documentation "Request cycle aware component the renders as an INPUT tag class"))
+
+(let ((class (find-class 'ccheckbox)))
+  (closer-mop:ensure-finalized class)
+  (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
+	(format nil "Description: ~a~%Parameters:~%~a~a~a~a~%~%~a"
+		"Function that instantiates a CCHECKBOX component and renders a html <input> tag of type \"checkbox\"."
+		*id-and-static-id-description*
+		(describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput))
+                (describe-html-attributes-from-class-slot-initargs (find-class 'cinput))
+		(describe-html-attributes-from-class-slot-initargs class)
+		(describe-component-behaviour class))))
+
+(defmethod wcomponent-template ((cinput ccheckbox))
+  (let* ((client-id (htcomponent-client-id cinput))
+         (translator (translator cinput))
+         (type (input-type cinput))
+         (value (translator-value-type-to-string translator (ccheckbox-value cinput)))
+         (current-value (translator-type-to-string translator cinput))
+         (class (css-class cinput)))
+    (when (component-validation-errors cinput)
+      (if (or (null class) (string= class ""))
+	  (setf class "error")
+	  (setf class (format nil "~a error" class))))
+    (input> :static-id client-id
+	    :type type
+	    :name (name-attr cinput)
+	    :class class
+	    :value value
+            :checked (when (and current-value (equal value current-value)) "checked")
+	    (wcomponent-informal-parameters cinput))))
+
+(defmethod wcomponent-after-rewind ((cinput ccheckbox) (page page))
+  (when (cform-rewinding-p (page-current-form page) page)
+    (let* ((visit-object (or (cinput-visit-object cinput) page))
+           (client-id (htcomponent-client-id cinput))
+           (translator (translator cinput))
+           (accessor (cinput-accessor cinput))
+           (writer (cinput-writer cinput))
+           (validator (validator cinput))
+           (result-as-list-p (cinput-result-as-list-p cinput))
+           (new-value (page-req-parameter page
+                                          client-id
+                                          result-as-list-p)))
+      (when new-value
+        (setf new-value (translator-string-to-type translator cinput)))
+      (unless (component-validation-errors cinput)
+        (when validator
+          (funcall validator (or new-value "")))
+        (unless (component-validation-errors cinput)
+          (if (and (null writer) accessor)
+              (funcall (fdefinition `(setf ,accessor)) new-value visit-object)
+              (funcall (fdefinition writer) new-value visit-object)))))))
+
+;-------------------------------------------------------------------------------------
+(defclass cradio (ccheckbox)
+    ()
+    (:metaclass metacomponent)
+    (:default-initargs :type "radio")
+    (:documentation "Request cycle aware component the renders as an INPUT tag class"))
+
+(let ((class (find-class 'cradio)))
+  (closer-mop:ensure-finalized class)
+  (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
+	(format nil "Description: ~a~%Parameters:~%~a~a~a~a~a~%~%~a"
+		"Function that instantiates a CRADIO component and renders a html <input> tag of type \"radio\"."
+		*id-and-static-id-description*
+		(describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput))
+                (describe-html-attributes-from-class-slot-initargs (find-class 'cinput))
+                (describe-html-attributes-from-class-slot-initargs (find-class 'ccheckbox))
+		(describe-html-attributes-from-class-slot-initargs class)
+		(describe-component-behaviour class))))
+
+(defmethod name-attr ((ccheckbox ccheckbox))
+  (htcomponent-real-id ccheckbox))
+
+(defmethod wcomponent-after-rewind ((cinput cradio) (page page))
+  (when (cform-rewinding-p (page-current-form page) page)
+    (let* ((visit-object (or (cinput-visit-object cinput) page))
+           (translator (translator cinput))
+           (accessor (cinput-accessor cinput))
+           (writer (cinput-writer cinput))
+           (validator (validator cinput))
+           (ccheckbox-test (ccheckbox-test cinput))
+           (result-as-list-p (cinput-result-as-list-p cinput))
+           (value (translator-value-string-to-type translator (ccheckbox-value cinput)))
+           (new-value (page-req-parameter page
+                                          (name-attr cinput)
+                                          result-as-list-p))
+           (checked))
+      (when new-value
+        (setf new-value (translator-string-to-type translator cinput)
+              checked (funcall ccheckbox-test value new-value)))
+      (when (and checked (null (component-validation-errors cinput)))
+        (when validator
+          (funcall validator (or new-value "")))
+        (when (null (component-validation-errors cinput))
+          (if (and (null writer) accessor)
+              (funcall (fdefinition `(setf ,accessor)) new-value visit-object)
+              (funcall (fdefinition writer) new-value visit-object)))))))
+
+(defmethod wcomponent-template ((cinput cradio))
+  (let* ((client-id (htcomponent-client-id cinput))
+         (translator (translator cinput))
+         (type (input-type cinput))
+         (value (translator-value-type-to-string translator (ccheckbox-value cinput)))
+         (current-value (translator-type-to-string translator cinput))
+         (class (css-class cinput)))
+    (when (component-validation-errors cinput)
+      (if (or (null class) (string= class ""))
+	  (setf class "error")
+	  (setf class (format nil "~a error" class))))
+    (input> :static-id client-id
+	    :type type
+	    :name (name-attr cinput)
+	    :class class
+	    :value value
+            :checked (when (and current-value (equal value current-value)) "checked")
+	    (wcomponent-informal-parameters cinput))))

Added: trunk/main/claw-html/src/meta.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-html/src/meta.lisp	Fri Jul 25 11:09:52 2008
@@ -0,0 +1,82 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/meta.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-html)
+
+(defclass metacomponent (standard-class)
+  ()
+  (:documentation "This is the meta class the must be set for every WCOMPONENT.
+It creates a function whose name is the WCOMPONENT class name plus the character '>'.
+The function may then be called as any other claw tag function."))
+
+(defmethod closer-mop:validate-superclass ((class metacomponent)(super standard-class))
+  t)
+
+
+(defun find-first-classdefault-initarg-value (initargs initarg)
+  "Returns the first class default init arg value matching matching the given INITARG"
+  (loop for current-initarg in initargs
+     do (when (eq (first current-initarg) initarg)
+          (return (second current-initarg)))))
+
+(defmethod initialize-instance :after ((class metacomponent) &key)
+  (let* ((name (class-name class))
+         (builder-function (format nil "~a>" name))
+         (symbolf (find-symbol builder-function)))
+    (unless symbolf
+      (setf symbolf (intern builder-function)))
+    (setf (fdefinition symbolf) #'(lambda(&rest rest) (build-component name rest)))))
+
+(defun describe-html-attributes-from-class-slot-initargs (class)
+  "Helper function that generates documentation for wcomponent init functions"
+  (let* ((class-slots (closer-mop:class-direct-slots class)))
+    (format nil "~{~%~a~}"
+            (remove-if #'null
+                       (reverse (loop for slot in class-slots
+                                   collect (let ((slot-initarg (first (closer-mop:slot-definition-initargs slot))))
+                                             (when slot-initarg
+                                               (format nil
+                                                       "- :~a ~a"
+                                                       slot-initarg
+                                                       (documentation slot 't))))))))))
+
+(defun describe-component-behaviour (class)
+  "Returns the behaviour descrioption of a WCOMPONENT init function. If it allows informal parameters, body and the reserved parameters"
+  (let* ((initargs (closer-mop:class-default-initargs class))
+         (reserved-parameters (find-first-classdefault-initarg-value initargs :reserved-parameters)))
+    (format nil "Allows informal parameters: ~a~%Allows body: ~a~%Reserved parameters: ~a"
+            (if (find-first-classdefault-initarg-value initargs :allow-informal-parameters)
+                "Yes"
+                "No")
+            (if (find-first-classdefault-initarg-value initargs :empty)
+                "No"
+                "Yes")
+            (if reserved-parameters
+                (format nil "~{:~a ~}" (eval reserved-parameters))
+                "NONE"))))

Added: trunk/main/claw-html/src/packages.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-html/src/packages.lisp	Fri Jul 25 11:09:52 2008
@@ -0,0 +1,256 @@
+;;; -*- 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)
+
+
+(defpackage :claw-html
+  (:use :cl :closer-mop :local-time :parenscript :cl-ppcre :split-sequence)
+  (:shadow :flatten)
+  (:documentation "A comprehensive web application framework and server for the Common Lisp programming language")
+  (: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*
+           #:*rewind-parameter*
+           #:*validation-errors*
+
+           #:error-page
+           #:render-error-page
+
+           ;#:duplicate-back-slashes
+           #:build-tagf
+           #:page
+           #:page-render
+           #:make-page-renderer
+           #:page-current-form
+           #:page-req-parameter
+           #:page-script-files
+           #:page-stylesheet-files
+           #:page-class-initscripts
+           #:page-instance-initscripts
+           #:page-current-component
+           #:page-body-init-scripts
+           #:htcomponent
+           #:htcomponent-page
+           #:htcomponent-body
+           #:htcomponent-empty
+           #:htcomponent-client-id
+           #:htcomponent-real-id
+           #:htcomponent-script-files
+           #:htcomponent-stylesheet-files
+           #:htcomponent-class-initscripts
+           #:htcomponent-instance-initscript
+           #:tag
+           #:tag-name
+           #:tag-attributes
+           #:htbody
+           #: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
+           #:generate-id
+           #:metacomponent
+           #:wcomponent
+           #:wcomponent-informal-parameters
+           #:wcomponent-allow-informal-parametersp
+           #:wcomponent-template
+           #:wcomponent-before-rewind
+           #:wcomponent-after-rewind
+           #:wcomponent-before-prerender
+           #:wcomponent-after-prerender
+           #:wcomponent-before-render
+           #:wcomponent-after-render
+           #:cform
+           #:form-method
+           #:cform>
+           #:action
+           #:action-link
+           #:action-link>
+           #:cinput
+           #:cinput>
+           #:ctextarea
+           #:ctextarea>
+           #:cinput-file
+           #:cinput-file>
+           #:cinput-result-as-list-p
+           #:ccheckbox
+           #:ccheckbox>
+           #:cradio
+           #:cradio>
+           #:cselect
+           #:cselect>
+           #:csubmit
+           #:csubmit>
+           #:csubmit-value
+           #:submit-link
+           #:submit-link>
+           #:input-type
+           #:ccheckbox-value
+           #:css-class
+           #:name-attr
+           
+           #:component-exceptions
+           #:*id-and-static-id-description*
+           
+           #:describe-component-behaviour
+           #:describe-html-attributes-from-class-slot-initargs
+           
+           ;;validation
+           #:translator
+           #:translator-integer
+           #:translator-number
+           #:translator-boolean
+           #:translator-date
+           #:translator-file
+           #:translator-encode
+           #:translator-decode
+           #:translator-string-to-type
+           #:translator-type-to-string
+           #:translator-value-decode
+           #:translator-value-encode
+           #:translator-value-string-to-type
+           #:translator-value-type-to-string
+           #:*simple-translator*
+           #:*boolean-translator*
+           #:*integer-translator*
+           #:*number-translator*
+           #:*date-translator-ymd*
+           #:*date-translator-time*
+           #:*file-translator*
+           #:validate
+           #:add-validation-error
+           #:component-validation-errors
+           #:validate-required
+           #:validate-size
+           #:validate-range
+           #:validate-number
+           #:validate-integer
+           #:validate-date-range
+           #:exception-monitor
+           #:exception-monitor>))
\ No newline at end of file

Added: trunk/main/claw-html/src/tags.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-html/src/tags.lisp	Fri Jul 25 11:09:52 2008
@@ -0,0 +1,1379 @@
+;;; -*- 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-html)
+
+(defgeneric page-req-parameter (page 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.
+ - PAGE 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 (page)
+  (: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.
+ - PAGE is the page instance that must be given"))
+
+(defgeneric page-json-prefix (page)
+  (:documentation "This internal method is called to get a prefix to prepend to a json reply when needed.
+ - PAGE is the page instance that must be given"))
+
+(defgeneric page-json-suffix (page)
+  (:documentation "This internal method is called to get a suffix to append to a json reply when needed.
+ - PAGE is the page instance that must be given"))
+
+(defgeneric page-content (page)
+  (:documentation "This method returns the page content to be redered.
+ - PAGE is the page instance that must be given"))
+
+(defgeneric page-init (page)
+  (:documentation "Internal method for page initialization.
+ - PAGE is the page instance that must be given"))
+
+(defgeneric page-render (page)
+  (:documentation "This method is the main method fired from the framework to render the desired page and to handle all the request cycle.
+ - PAGE is the page instance that must be given"))
+
+(defgeneric page-init-injections (page)
+  (: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).
+ - PAGE is the page instance that must be given"))
+
+(defgeneric page-render-headings (page)
+  (: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.
+ - PAGE is the page instance that must be given"))
+
+(defgeneric page-request-parameters (page)
+  (:documentation "This internal method builds the get and post parameters into an hash table.
+Parameters are collected as lists so that this method can collect parameters that appear moter then once."))
+
+(defgeneric page-print-tabulation (page)
+  (: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.
+ - PAGE is the page instance that must be given"))
+
+(defgeneric page-newline (page)
+  (:documentation "This internal method simply writes the rest of page content on a new line when needed.
+ - PAGE is the page instance that must be given"))
+
+(defgeneric page-format (page 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.
+ - PAGE 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 (page 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.
+ - PAGE 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)
+  (: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 is the page instance that must be given"))
+
+(defgeneric htbody-init-scripts-tag (page &optional on-load)
+  (:documentation "Encloses the init inscance scripts injected into the page into a <script> tag component
+See PAGE-BODY-INIT-SCRIPTS form more info. If the ON-LOAD parameter it not nil, then the script will be executed
+on the onload document event.
+ - PAGE is the page instance that must be given"))
+
+(defgeneric page-current-component (page)
+  (:documentation "The component being processed into one of the rendering phases"))
+
+(defgeneric htcomponent-rewind (htcomponent page)
+  (: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.
+ - HTCOMPONENT is the htcomponent instance that must be rewound
+ - PAGE is the page instance that must be given"))
+
+(defgeneric htcomponent-prerender (htcomponent page)
+  (: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.
+ - HTCOMPONENT is the htcomponent instance that must be prerendered
+ - PAGE is the page instance that must be given"))
+
+(defgeneric htcomponent-render (htcomponent page)
+  (:documentation "This internal method is the last called during the request cycle phase.
+It is used to effectively render the component into the page.
+ - HTCOMPONENT is the htcomponent instance that must be rendered
+ - PAGE is the page instance that must be given"))
+
+(defgeneric htcomponent-can-print (htcomponent)
+  (:documentation "This internal method is used in an xhr call to determine
+if a component may be rendered into the reply
+ - HTCOMPONENT is the htcomponent instance"))
+
+(defgeneric htcomponent-json-print-start-component (htcomponent)
+  (:documentation "Internal method called to render the json reply during the render cycle phase
+on component start.
+ - HTCOMPONENT is the htcomponent instance"))
+
+(defgeneric htcomponent-json-print-end-component (htcomponent)
+  (:documentation "Internal method called to render the json reply during the render cycle phase
+on component end.
+ - HTCOMPONENT is the htcomponent instance"))
+
+(defgeneric tag-render-starttag (tag page)
+  (:documentation "Internal method to print out the opening html tag during the render phase
+ - TAG is the tag instance
+ - PAGE the page instance"))
+
+(defgeneric tag-render-endtag (tag page)
+  (:documentation "Internal method to print out the closing html tag during the render phase
+ - TAG is the tag instance
+ - PAGE the page instance"))
+
+(defgeneric tag-render-attributes (tag page)
+  (:documentation "Internal method to print out the attributes of an html tag during the render phase
+ - TAG is the tag instance
+ - PAGE the page instance"))
+
+(defgeneric tag-attributes (tag)
+  (:documentation "Returns an alist of tag attributes"))
+
+(defgeneric (setf htcomponent-page) (page htcomponent)
+  (:documentation "Internal method to set the component owner page and to assign
+an unique id attribute when provided.
+ - HTCOMPONENT is the tag instance
+ - PAGE the page instance"))
+
+(defgeneric (setf slot-initialization) (value wcomponent slot-initarg)
+  (:documentation "Sets a slot by its :INITARG. It's used just after instance creation"))
+
+(defgeneric wcomponent-before-rewind (wcomponent page)
+  (:documentation "Method called by the framework before the rewinding phase. It is intended to be eventually overridden in descendant classes.
+ - WCOMPONENT is the tag instance
+ - PAGE the page instance"))
+
+(defgeneric wcomponent-after-rewind (wcomponent page)
+  (:documentation "Method called by the framework after the rewinding phase. It is intended to be eventually overridden in descendant classes.
+ - WCOMPONENT is the tag instance
+ - PAGE the page instance"))
+(defgeneric wcomponent-before-prerender (wcomponent page)
+  (:documentation "Method called by the framework before the pre-rendering phase. It is intended to be eventually overridden in descendant classes.
+ - WCOMPONENT is the tag instance
+ - PAGE the page instance"))
+
+(defgeneric wcomponent-after-prerender (wcomponent page)
+  (:documentation "Method called by the framework after the pre-rendering phase. It is intended to be eventually overridden in descendant classes.
+ - WCOMPONENT is the tag instance
+ - PAGE the page instance"))
+(defgeneric wcomponent-before-render (wcomponent page)
+  (:documentation "Method called by the framework before the rendering phase. It is intended to be eventually overridden in descendant classes.
+ - WCOMPONENT is the tag instance
+ - PAGE the page instance"))
+
+(defgeneric wcomponent-after-render (wcomponent page)
+  (:documentation "Method called by the framework after the rendering phase. It is intended to be eventually overridden in descendant classes.
+ - WCOMPONENT is the tag instance
+ - PAGE the page instance"))
+
+(defgeneric wcomponent-template (wcomponent)
+  (:documentation "The component template. What gives to each wcomponent its unique aspect and features"))
+
+(defgeneric simple-message-dispatcher-add-message (simple-message-dispatcher locale key value)
+  (:documentation "Adds a key value pair to a given locale for message translation"))
+
+(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 *rewind-parameter* "rewindobject"
+  "The request parameter name 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")
+  "List of html empty tags")
+
+(defvar *validation-errors* nil
+  "A plist where key is a component id and value is a list of validation error messages related to that component.")
+
+(defvar *validation-compliances* nil
+  "List of component id that pass the validation")
+
+(defvar *claw-current-page* nil
+    "The CLAW page currently rendering")
+
+(defvar *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 \"compId_1\", the third time will be \"compId_2\" and so on")
+
+(defvar *simple-translator* nil
+  "*SIMPLE-TRANSLATOR* is the default translator for any CINPUT component.
+Its encoder and decoder methods pass values unchanged")
+
+(defvar *file-translator* nil
+  "*FILE-TRANSLATOR* is the default translator for any CINPUT component of type \"file\".")
+
+
+
+(defun flatten (tree &optional result-list)
+  "Traverses the tree in order, collecting even non-null leaves into a list."
+  (let ((result result-list))
+    (loop for element in tree
+       do (cond
+            ((consp element) (setf result (append (nreverse (flatten element result-list)) result)))
+            (t (push element result))))
+    (nreverse result)))
+
+(defun add-validation-compliance (id)
+  "Adds a component id to the list of components that pass validation during form rewinding"
+  (setf *validation-compliances* (nconc *validation-compliances* (list id))))
+
+(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."
+  (setf *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 (and (null body)
+                   (or (keywordp elem)
+                       (keywordp last-elem)))
+              (push elem attributes)
+              (when elem
+                (push elem body))))
+    (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 *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 emptyp &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
+- EMPTYP 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 *id-table-map*)
+         (attributes (first fbody))
+         (id (getf attributes :id))
+         (static-id (getf attributes :static-id))
+         (render-condition (getf attributes :render-condition))
+         (real-id (or static-id id))
+         (instance))
+    (when static-id
+      (remf attributes :id)
+      (setf id nil))
+    (when render-condition
+      (remf attributes :render-condition))
+    (setf instance (make-instance parent
+                                  :empty emptyp
+                                  :real-id real-id
+                                  :name (string-downcase tag-name)
+                                  :render-condition render-condition
+                                  :attributes attributes
+                                  :body (second fbody)))
+    (when real-id
+      (if (null static-id)
+          (when (and id-table-map id)
+            (setf (htcomponent-client-id instance) (generate-id id)))
+          (setf (htcomponent-client-id instance) static-id)))
+    instance))
+
+(defun generate-tagf (tag-name emptyp)
+  "Internal function that generates an htcomponent creation function from the component class name
+- TAG-NAME the symbol class name of the component
+- EMPTYP determines if the tag must be rendered as an empty tag during the request cycle phase."
+  (let ((fsymbol (intern (format nil "~a>" (string-upcase tag-name)))))
+    (setf (fdefinition fsymbol)
+          #'(lambda (&rest rest) (build-tagf tag-name 'tag emptyp rest)))
+    (setf (documentation fsymbol 'function) (format nil "This function generates the ~a<~a> html tag"
+                                                    (if  emptyp
+                                                         "empty "
+                                                         "")
+                                                    tag-name))))
+
+
+;;;----------------------------------------------------------------
+#|
+(defclass message-dispatcher ()
+  ()
+  (:documentation "This is and interface for message dispatchers"))
+
+(defclass simple-message-dispatcher (message-dispatcher)
+  ((locales :initform (make-hash-table :test #'equal)
+            :accessor simple-message-dispatcher-locales
+            :documentation "Hash table of locales strings and KEY/VALUE message pairs"))
+  (:documentation "A message disptcher that leave data unchanged during encoding and decoding phases."))
+
+(defclass i18n-aware (message-dispatcher)
+  ((message-dispatcher :initarg :message-dispatcher
+                       :accessor message-dispatcher
+                       :documentation "Reference to a MESSAGE-DISPATCHER instance"))
+  (:default-initargs :message-dispatcher nil)
+  (:documentation "All classes that need to dispatch messages are subclasses of I18N-AWARE"))
+|#
+
+(defclass page()
+  ((writer :initarg :writer
+           :accessor page-writer :documentation "The output stream for this page instance")
+   (can-print :initform nil
+              :accessor page-can-print
+              :documentation "Controls the printing process when a json request is dispatched.
+Only components with a matching id and their contents can be printed")
+   (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")
+   (doc-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.")
+   (json-component-id-list :initform ()
+                           :accessor page-json-component-id-list :documentation "The current component that will ber rendered into json reply object in an xhr call.")
+   (request-parameters :initarg :request-parameters
+                       :documentation "This slot is used to avoid PAGE-REQUEST-PARAMETERS multimple computations, saving the result of this function on the first call and then using the cached value.")
+   (post-parameters :initarg :post-parameters
+                    :reader page-post-parameters
+                    :documentation "http request post parameters")
+   (get-parameters :initarg :get-parameters
+                    :reader page-get-parameters
+                    :documentation "http request get parameters")
+   (components-stack :initform nil
+                     :accessor page-components-stack
+                     :documentation "A stack of components enetered into rendering process.")
+   (mime-type :initarg :mime-type
+              :accessor page-mime-type
+              :documentation "Define the mime type of the page when rendered")
+   (external-format-encoding :initarg :external-format-encoding
+                             :accessor page-external-format-encoding
+                             :documentation "Symbol for page charset encoding \(Such as UTF-8)")
+   (injection-writing-p :initform nil
+                       :accessor page-injection-writing-p
+                       :documentation "Flag that becomes true when rendering page injections"))
+  (:default-initargs :writer t
+    :external-format-encoding :utf-8
+    :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
+    :mime-type "text/html")
+  (:documentation "A page object holds claw components to be rendered") )
+
+(defun make-page-renderer (page-class http-post-parameters http-get-parameters) 
+  "Generates a lambda function from PAGE-RENDER method, that may be used into LISPLET-REGISTER-FUNCTION-LOCATION"
+  #'(lambda () (with-output-to-string (*standard-output*)
+                 (page-render (make-instance page-class :post-parameters http-post-parameters :get-parameters http-get-parameters)))))
+
+(defclass htcomponent ()
+  ((page :initarg :page
+         :reader htcomponent-page :documentation "The owner page")
+   (json-render-on-validation-errors-p :initarg :json-render-on-validation-errors-p
+                                       :reader htcomponent-json-render-on-validation-errors-p
+                                       :documentation "If from submission contains exceptions and the value is not nil, the component is rendered into the xhr json reply.")
+   (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")
+   (real-id :initarg :real-id
+            :accessor htcomponent-real-id :documentation "The tag real id got from :ID or :STATIC-ID")
+   (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")
+   (render-condition :initarg :render-condition
+                     :accessor htcomponent-render-condition
+                     :documentation "When not nil the component followr the pre-rendering and rendering phase only if the execution of this function isn't nil")
+   (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
+    :json-render-on-validation-errors-p nil
+    :real-id nil
+    :attributes nil
+    :empty nil
+    :render-condition 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 ((emptyp (getf keys :empty))
+        (body (getf keys :body)))
+    (when (and (not (null emptyp))
+               (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)
+  "This function generates the <script> html tag"
+  (build-tagf "script" 'htscript nil rest))
+
+(defclass htlink (tag) ()
+  (:documentation "Creates a component for rendering a <link> tag"))
+
+(defun link> (&rest rest)
+  "This function generates the <link> html tag"
+  (build-tagf "link" 'htlink t rest))
+
+(defclass htbody (tag) ()
+  (:documentation "Creates a component for rendering a <body> tag"))
+
+(defun body> (&rest rest)
+  "This function generates the <body> html tag"
+  (build-tagf "body" 'htbody nil rest))
+
+(defclass hthead (tag) ()
+  (:documentation "Creates a component for rendering a <head> tag"))
+
+(defun head> (&rest rest)
+  "Renders a <head> tag"
+  (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
+        *empty-tags*)
+
+(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"))
+
+;;;--------------------METHODS implementation----------------------------------------------
+(defmethod (setf htcomponent-page) ((page page) (htcomponent htcomponent))
+  (setf (slot-value htcomponent 'page) page)
+  (when (htcomponent-real-id htcomponent)
+    (let ((id (getf (htcomponent-attributes htcomponent) :id))
+          (static-id (getf (htcomponent-attributes htcomponent) :static-id))
+          (client-id (when (slot-boundp htcomponent 'client-id) (htcomponent-client-id htcomponent))))
+      (unless client-id
+        (if static-id
+            (setf (htcomponent-client-id htcomponent) static-id)
+            (setf (htcomponent-client-id htcomponent) (generate-id id)))))))
+
+(defmethod page-request-parameters ((page page))
+  (if (null (slot-value page 'request-parameters))
+      (let ((parameters (append (page-post-parameters page) (page-get-parameters page)))
+            (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 page 'request-parameters) pparameters))
+      (slot-value page 'request-parameters)))
+
+(defmethod page-req-parameter ((page page) name &optional as-list)
+  (let ((parameters (page-request-parameters page))
+        (retval))
+    (when parameters
+      (setf retval (gethash (string-upcase name) parameters))
+      (if (or (null retval) as-list)
+          retval
+          (first retval)))))
+
+(defmethod page-format ((page page) str &rest rest)
+  (let ((jsonp (page-json-id-list page))
+        (writer (page-writer page)))
+    (if (null jsonp)
+        (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 ((page page) str &rest rest)
+  (let ((writer (page-writer page)))
+    (apply #'format writer str rest)))
+
+(defmethod page-json-id-list ((page page))
+  (page-req-parameter page "json" t))
+
+(defmethod page-json-prefix ((page page))
+  (or (page-req-parameter page "jsonPrefix" nil) ""))
+
+(defmethod page-json-suffix ((page page))
+  (or (page-req-parameter page "jsonSuffix" nil) ""))
+
+(defmethod page-init ((page page))
+  (progn
+    (reset-request-id-table-map)
+    (setf (page-can-print page) (null (page-json-id-list page)))
+    (reset-request-id-table-map)
+    (setf (page-tabulator page) 0)))
+
+(defmethod page-render-headings ((page page))
+  (let* ((jsonp (page-json-id-list page))
+         (encoding (page-external-format-encoding page))
+         (xml-p (page-xmloutput page))
+         (doc-type (page-doc-type page)))
+    (when (null jsonp)
+      (when xml-p
+        (page-format-raw page "<?xml version=\"1.0\" encoding=\"~a\"?>~%" encoding))
+      (when doc-type
+        (page-format-raw page "~a~%" doc-type)))))
+
+(defun json-validation-errors ()
+  "Composes the error part for the json reply"
+  (let ((validation-errors *validation-errors*))
+    (if validation-errors
+        (let* ((errors (loop for (component-id messages) on validation-errors by #'cddr
+                          collect (symbol-name component-id)
+                          collect (push 'array messages)))
+               (js-struct (ps:ps* `(create ,@errors))))
+          (subseq js-struct 0 (1- (length js-struct))))
+        "null")))
+
+(defun json-validation-compliances ()
+  "Composes the compliances part to form validation for the json reply"
+  (let ((js-array (ps:ps* `(array ,@*validation-compliances*))))
+    (subseq js-array 0 (1- (length js-array)))))
+
+(defmethod page-render ((page page))
+  (let ((*claw-current-page* page)
+        (*id-table-map* nil)
+        (*validation-errors* nil)
+        (*validation-compliances* nil)
+        (body (page-content page))
+        (jsonp (page-json-id-list page)))
+    (if (null body)
+        (format nil "null body for page ~a~%" (type-of page))
+        (progn
+          (page-init page)
+          (when (page-req-parameter page *rewind-parameter*)
+            (htcomponent-rewind body page))
+          (page-init page)
+          (htcomponent-prerender (page-content page) page) ;Here we need a fresh new body!!!
+          (page-render-headings page)
+          (page-init page)
+          (when jsonp
+            (page-format-raw page (page-json-prefix page))
+            (page-format-raw page "{components:{"))
+          (htcomponent-render (page-content page) page) ;Here we need a fresh new body!!!
+          (when jsonp
+            (page-format-raw page "},classInjections:\"")
+            (setf (page-can-print page) t
+                  (page-injection-writing-p page) t)
+            (dolist (injection (page-init-injections page))
+              (when injection
+                (htcomponent-render injection page)))
+            (page-format-raw page "\",instanceInjections:\"")
+            (let ((init-scripts (htbody-init-scripts-tag page)))
+              (when init-scripts
+                (htcomponent-render init-scripts page)))
+            (page-format-raw page "\",errors:")
+            (page-format-raw page (json-validation-errors))
+            (page-format-raw page ",valid:")
+            (page-format-raw page (json-validation-compliances))
+            (page-format-raw page "}")
+            (page-format-raw page (page-json-suffix page)))))))
+
+(defmethod page-body-init-scripts ((page page))
+  (let ((js-body ""))
+    (dolist (current-js (reverse (page-instance-initscripts page)))
+      (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 ((page page))
+  (let ((jsonp (page-json-id-list page))
+        (tabulator (page-tabulator page))
+        (indent-p (page-indent page)))
+    (when (and (<= 0 tabulator) indent-p (null jsonp))
+      (page-format-raw page "~a"
+                       (make-string tabulator :initial-element #\tab)))))
+
+(defmethod page-newline ((page page))
+  (let ((jsonp (page-json-id-list page))
+        (indent-p (page-indent page)))
+    (when (and indent-p (null jsonp))
+      (page-format-raw page "~%"))))
+
+(defmethod page-init-injections ((page page))
+  (let ((tag-list)
+        (class-init-scripts ""))
+    (dolist (script (reverse (page-class-initscripts page)))
+      (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 page))
+      (if (typep js-file 'htcomponent)
+          (push js-file tag-list)
+          (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 page))
+      (if (typep css-file 'htcomponent)
+          (push css-file tag-list)
+          (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))
+
+(defmethod page-current-component ((page page))
+  (car (page-components-stack page)))
+
+(defun current-component ()
+  "Returns the component that is currently rendering"
+  (when *claw-current-page*
+    (car (page-components-stack *claw-current-page*))))
+;;;========= HTCOMPONENT ============================
+(defmethod htcomponent-can-print ((htcomponent htcomponent))
+  (let* ((id (when (slot-boundp htcomponent 'client-id) (htcomponent-client-id htcomponent)))
+         (page (htcomponent-page htcomponent))
+         (print-status (page-can-print page))
+         (validation-errors *validation-errors*)
+         (json-render-on-validation-errors-p (htcomponent-json-render-on-validation-errors-p htcomponent))
+         (render-p (or (and (member id (page-json-id-list page) :test #'string=)
+                            (null validation-errors))
+                       print-status)))
+    (or json-render-on-validation-errors-p print-status render-p)))
+
+(defmethod htcomponent-json-print-start-component ((htcomponent htcomponent))
+  (let* ((page (htcomponent-page htcomponent))
+         (jsonp (page-json-id-list page))
+         (id (when (slot-boundp htcomponent 'client-id) (htcomponent-client-id htcomponent)))
+         (validation-errors *validation-errors*))
+    (when (and jsonp
+               (or (and (null validation-errors)
+                        (member id jsonp :test #'string-equal))
+                   (htcomponent-json-render-on-validation-errors-p htcomponent)))
+      (when (> (page-json-component-count page) 0)
+        (page-format page ","))
+      (page-format-raw page "~a:\"" id)
+      (push id (page-json-component-id-list page))
+      (incf (page-json-component-count page)))))
+
+(defmethod htcomponent-json-print-end-component ((htcomponent htcomponent))
+  (let* ((page (htcomponent-page htcomponent))
+         (jsonp (page-json-id-list page))
+         (id (when (slot-boundp htcomponent 'client-id) (htcomponent-client-id htcomponent)))
+         (validation-errors *validation-errors*))
+    (when (and jsonp
+               (or (and (null validation-errors)
+                        (member id jsonp :test #'string-equal))
+                   (htcomponent-json-render-on-validation-errors-p htcomponent)))
+      (pop (page-json-component-id-list page))
+      (page-format-raw page "\""))))
+
+(defmethod htcomponent-rewind :before ((htcomponent htcomponent) (page page))
+  (setf (htcomponent-page htcomponent) page)
+  (push htcomponent (page-components-stack page)))
+
+(defmethod htcomponent-prerender :before ((htcomponent htcomponent) (page page))
+  (let ((render-condition (htcomponent-render-condition htcomponent)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (setf (htcomponent-page htcomponent) page)
+      (push htcomponent (page-components-stack page)))))
+
+(defmethod htcomponent-render :before ((htcomponent htcomponent) (page page))
+  (let ((render-condition (htcomponent-render-condition htcomponent)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (setf (htcomponent-page htcomponent) page)
+      (push htcomponent (page-components-stack page)))))
+
+(defmethod htcomponent-rewind :after ((htcomponent htcomponent) (page page))
+  (pop (page-components-stack page)))
+
+(defmethod htcomponent-prerender :after ((htcomponent htcomponent) (page page))
+  (let ((render-condition (htcomponent-render-condition htcomponent)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (pop (page-components-stack page)))))
+
+(defmethod htcomponent-render :after ((htcomponent htcomponent) (page page))
+  (let ((render-condition (htcomponent-render-condition htcomponent)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (pop (page-components-stack page)))))
+
+(defmethod htcomponent-rewind ((htcomponent htcomponent) (page page))
+  (dolist (tag (htcomponent-body htcomponent))
+    (when (subtypep (type-of tag) 'htcomponent)
+      (htcomponent-rewind tag page))))
+
+(defmethod htcomponent-prerender ((htcomponent htcomponent) (page page))
+  (let ((previous-print-status (page-can-print page))
+        (render-condition (htcomponent-render-condition htcomponent)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (when (null previous-print-status)
+        (setf (page-can-print page) (htcomponent-can-print htcomponent)))
+      (dolist (tag (htcomponent-body htcomponent))
+        (when (subtypep (type-of tag) 'htcomponent)
+          (htcomponent-prerender tag page)))
+      (when (null previous-print-status)
+        (setf (page-can-print page) nil)))))
+
+(defmethod htcomponent-render ((htcomponent htcomponent) (page page))
+  (let ((body-list (htcomponent-body htcomponent))
+        (previous-print-status (page-can-print page))
+        (render-condition (htcomponent-render-condition htcomponent)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (when (null previous-print-status)
+        (setf (page-can-print page) (htcomponent-can-print htcomponent))
+        (htcomponent-json-print-start-component htcomponent))
+      (dolist (child-tag body-list)
+        (when child-tag
+          (cond
+            ((stringp child-tag) (htcomponent-render ($> child-tag) page))
+            ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
+            (t (htcomponent-render child-tag page)))))
+      (when (null previous-print-status)
+        (setf (page-can-print page) nil)
+        (htcomponent-json-print-end-component htcomponent)))))
+
+;;;========= TAG =====================================
+(defmethod tag-attributes ((tag tag))
+  (htcomponent-attributes tag))
+
+(defmethod tag-render-attributes ((tag tag) (page page))
+  (when (htcomponent-attributes tag)
+    (loop for (k v) on (htcomponent-attributes tag) by #'cddr
+       do (progn
+            (assert (keywordp k))
+            (when (and (functionp v) (not (eq k :render-condition)))
+              (setf v (funcall v)))
+            (when (numberp v)
+              (setf v (princ-to-string v)))
+            (when (and (not (eq k :render-condition)) v (string-not-equal v ""))
+              (page-format page " ~a=\"~a\""
+                           (if (eq k :static-id)
+                               "id"
+                               (parenscript::symbol-to-js k))
+                           (let ((s (if (eq k :id)
+                                        (prin1-to-string (htcomponent-client-id tag))
+                                        (if (eq t v)
+                                            "\"true\""
+                                            (prin1-to-string v))))) ;escapes double quotes
+                             (subseq s 1 (1- (length s))))))))))
+
+(defmethod tag-render-starttag ((tag tag) (page page))
+  (let ((tagname (tag-name tag))
+        (id (when (slot-boundp tag 'client-id) (htcomponent-client-id tag)))
+        (jsonp (page-json-id-list page))
+        (emptyp (htcomponent-empty tag))
+        (xml-p (page-xmloutput page))
+        (injection-writing-p (page-injection-writing-p page)))
+    (setf (page-lasttag page) tagname)
+    (when (or injection-writing-p
+              (null jsonp)
+              (null (and jsonp 
+                         (string= id (first (page-json-component-id-list page))))))
+      (page-newline page)
+      (page-print-tabulation page)
+      (page-format page "<~a" tagname)
+      (tag-render-attributes tag page)
+      (if (null emptyp)
+          (progn
+            (page-format page ">")
+            (incf (page-tabulator page)))
+          (if (null xml-p)
+              (page-format page ">")
+              (page-format page "/>"))))))
+
+(defmethod tag-render-endtag ((tag tag) (page page))
+  (let ((tagname (tag-name tag))
+        (id (when (slot-boundp tag 'client-id) (htcomponent-client-id tag)))
+        (jsonp (page-json-id-list page))
+        (previous-tagname (page-lasttag page))
+        (emptyp (htcomponent-empty tag))
+        (injection-writing-p (page-injection-writing-p page)))
+    (when (and (null emptyp)
+               (or injection-writing-p
+                   (null jsonp)
+                   (null (and jsonp 
+                              (string= id (first (page-json-component-id-list page)))))))
+      (progn
+        (decf (page-tabulator page))
+        (if (string= tagname previous-tagname)
+            (progn
+              (page-format page "</~a>" tagname))
+            (progn
+              (page-newline page)
+              (page-print-tabulation page)
+              (page-format page "</~a>" tagname)))))
+    (setf (page-lasttag page) nil)))
+
+(defmethod htcomponent-render ((tag tag) (page page))
+  (let ((body-list (htcomponent-body tag))
+        (previous-print-status (page-can-print page))
+        (render-condition (htcomponent-render-condition tag)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (when (null previous-print-status)
+        (setf (page-can-print page) (htcomponent-can-print tag))
+        (htcomponent-json-print-start-component tag))
+      (when (or (page-can-print page) previous-print-status)
+        (tag-render-starttag tag page))
+      (dolist (child-tag body-list)
+        (when child-tag
+          (cond
+            ((stringp child-tag) (htcomponent-render ($> child-tag) page))
+            ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
+            (t (htcomponent-render child-tag page)))))
+      (when (or (page-can-print page) previous-print-status)
+        (tag-render-endtag tag page))
+      (unless previous-print-status
+        (setf (page-can-print page) nil)
+        (htcomponent-json-print-end-component tag)))))
+
+;;;========= HTHEAD ======================================
+(defmethod htcomponent-render ((hthead hthead) (page page))
+  (let ((render-condition (htcomponent-render-condition hthead)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (when (null (page-json-id-list page))
+        (let ((body-list (htcomponent-body hthead))
+              (injections (page-init-injections page))
+              (encoding (page-external-format-encoding page)))
+          (tag-render-starttag hthead page)
+          (htcomponent-render (meta> :http-equiv "Content-Type"
+                                     :content (format nil "~a;charset=~a"
+                                                      (page-mime-type page)
+                                                      encoding))
+                              page)
+          (dolist (child-tag body-list)
+            (when child-tag
+              (cond
+                ((stringp child-tag) (htcomponent-render ($> child-tag) page))
+                ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
+                (t (htcomponent-render child-tag page)))))
+          (dolist (injection injections)
+            (when injection
+              (htcomponent-render injection page)))
+          (tag-render-endtag hthead page))))))
+
+;;;========= HTSTRING ===================================
+
+(defmethod htcomponent-rewind((htstring htstring) (page page)))
+(defmethod htcomponent-prerender((htstring htstring) (page page)))
+
+(defmethod htcomponent-render ((htstring htstring) (page page))
+  (let ((body (htcomponent-body htstring))
+        (jsonp (not (null (page-json-id-list page))))
+        (print-p (page-can-print page))
+        (render-condition (htcomponent-render-condition htstring)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (when (and print-p body)
+        (when (functionp body)
+          (setf body (funcall body)))
+        (when jsonp
+          (setf body (regex-replace-all "\""
+                                        (regex-replace-all "\\\\\""
+                                                           (regex-replace-all "\\n"
+                                                                              body
+                                                                              "\\n")
+                                                           "\\\\\\\"")
+                                        "\\\"")))
+        (if (htstring-raw htstring)
+            (page-format-raw page body)
+            (loop for ch across body
+               do (case ch
+                    ((#\<) (page-format-raw page "<"))
+                    ((#\>) (page-format-raw page ">"))
+                    ((#\&) (page-format-raw page "&"))
+                    (t (page-format-raw page "~a" ch)))))))))
+
+;;;========= HTSCRIPT ===================================
+(defmethod htcomponent-prerender((htscript htscript) (page page)))
+
+(defmethod htcomponent-render ((htscript htscript) (page page))
+  (let ((xml-p (page-xmloutput page))
+        (body (htcomponent-body htscript))
+        (previous-print-status (page-can-print page))
+        (render-condition (htcomponent-render-condition htscript)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (when (null previous-print-status)
+        (setf (page-can-print page) (htcomponent-can-print htscript))
+        (htcomponent-json-print-start-component htscript))
+      (unless (getf (htcomponent-attributes htscript) :type)
+        (append '(:type "text/javascript") (htcomponent-attributes htscript)))
+      (when (page-can-print page)
+        (tag-render-starttag htscript page)
+        (when (and (null (getf (htcomponent-attributes htscript) :src))
+                   (not (null (htcomponent-body htscript))))
+          (if (null xml-p)
+              (page-format page "~%//<!--~%")
+              (page-format page "~%//<[CDATA[~%"))
+          (unless (listp body)
+            (setf body (list body)))
+          (dolist (element body)
+            (when element
+              (cond
+                ((stringp element) (htcomponent-render ($raw> element) page))
+                ((functionp element) (htcomponent-render ($raw> (funcall element)) page))
+                (t (htcomponent-render element page)))))
+          (if (null xml-p)
+              (page-format page "~%//-->")
+              (page-format page "~%//]]>")))
+        (setf (page-lasttag page) nil)
+        (tag-render-endtag htscript page))
+      (when (null previous-print-status)
+        (setf (page-can-print page) nil)
+        (htcomponent-json-print-end-component htscript)))))
+
+;;;========= HTLINK ====================================
+
+(defmethod htcomponent-render ((htlink htlink) (page page))
+  (let ((previous-print-status (page-can-print page))
+        (render-condition (htcomponent-render-condition htlink)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (when (null previous-print-status)
+        (setf (page-can-print page) (htcomponent-can-print htlink))
+        (htcomponent-json-print-start-component htlink))
+      (when (page-can-print page)
+        (unless (getf (htcomponent-attributes htlink) :type)
+          (append '(:type "text/css") (htcomponent-attributes htlink)))
+        (unless (getf (htcomponent-attributes htlink) :rel)
+          (append '(:rel "styleshhet") (htcomponent-attributes htlink)))
+        (tag-render-starttag htlink page)
+        (tag-render-endtag htlink page))
+      (when (null previous-print-status)
+        (setf (page-can-print page) nil)
+        (htcomponent-json-print-end-component htlink)))))
+
+;;;========= HTBODY ===================================
+(defmethod htcomponent-render ((htbody htbody) (page page))
+  (let ((body-list (htcomponent-body htbody))
+        (previous-print-status (page-can-print page))
+        (render-condition (htcomponent-render-condition htbody)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (when (or (page-can-print page) previous-print-status)
+        (setf (page-can-print page) (htcomponent-can-print htbody))
+        (htcomponent-json-print-start-component htbody))
+      (when (page-can-print page)
+        (tag-render-starttag htbody page))
+      (dolist (child-tag body-list)
+        (when child-tag
+          (cond
+            ((stringp child-tag) (htcomponent-render ($> child-tag) page))
+            ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
+            (t (htcomponent-render child-tag page)))))
+      (when (page-can-print page)
+        (htcomponent-render (htbody-init-scripts-tag page t) page)
+        (tag-render-endtag htbody page))
+      (when (or (page-can-print page) previous-print-status)
+        (setf (page-can-print page) nil)
+        (htcomponent-json-print-end-component htbody)))))
+
+(defmethod htbody-init-scripts-tag ((page page) &optional on-load)
+  (let ((js (script> :type "text/javascript"))
+        (js-control-string-directive (if on-load 
+                                         "
+var bodyInitFunction = function\(e){~{~a~}};~%
+if (/MSIE (\\d+\\.\\d+);/.test(navigator.userAgent)) {~%
+  window.attachEvent\('onload', bodyInitFunction);~%
+} else {~%
+  document.addEventListener\('DOMContentLoaded', bodyInitFunction, false);~%
+}"
+                                         "~{~a~}~%"))
+        (page-body-init-scripts (page-body-init-scripts page)))
+    (setf (htcomponent-page js) page
+          (htcomponent-body js) (when page-body-init-scripts
+                                  (format nil js-control-string-directive (if (listp page-body-init-scripts)
+                                                                              page-body-init-scripts
+                                                                              (list page-body-init-scripts)))))
+    js))
+
+;;;========= WCOMPONENT ===================================
+(defclass wcomponent (htcomponent)
+  ((reserved-parameters :initarg :reserved-parameters
+                        :accessor wcomponent-reserved-parameters
+                        :type cons
+                        :documentation "Parameters that may not be used in the constructor function")
+   (json-error-monitor-p :initarg :json-error-monitor-p
+                         :accessor htcomponent-json-error-monitor-p
+                         :documentation "When not nil, if the client has sent a XHR call, let the page to fill the errorComponents property of the json reply.")
+   (informal-parameters :initform ()
+                        :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"))
+  (:default-initargs :reserved-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."))
+
+(defun slot-initarg-p (initarg class-precedence-list)
+  "Returns nil if a slot with that initarg isn't found into the list of classes passed"
+  (loop for class in class-precedence-list
+     do (let* ((direct-slots (closer-mop:class-direct-slots class))
+               (result (loop for slot in direct-slots
+                          do (when (eq (first (closer-mop:slot-definition-initargs slot)) initarg)
+                               (return initarg)))))
+          (when result
+            (return result)))))
+
+(defmethod initialize-instance :after ((instance wcomponent) &rest rest)
+  (let* ((class-precedence-list (closer-mop:compute-class-precedence-list (class-of instance)))
+         (informal-parameters (loop for (k v) on rest by #'cddr
+                                 for result = ()
+                                 do (unless (slot-initarg-p k class-precedence-list)
+                                      (push v result)
+                                      (push k result))
+                                 finally (return result))))
+    (setf (slot-value instance 'informal-parameters) informal-parameters)))
+
+(defmethod (setf slot-initialization) (value (wcomponent wcomponent) slot-initarg)
+  (let* ((initarg (if (or (eq slot-initarg :static-id) (eq slot-initarg :id)) :client-id slot-initarg))
+         (new-value (if (eq slot-initarg :id) (generate-id value) value))
+         (slot-name (loop for slot-definition in (closer-mop:class-slots (class-of wcomponent))
+                       do (when (eq (car (last (closer-mop:slot-definition-initargs slot-definition))) initarg)
+                            (return (closer-mop:slot-definition-name slot-definition))))))
+    (if (find initarg (wcomponent-reserved-parameters wcomponent))
+        (error (format nil "Parameter ~a is reserved" initarg))
+        (if slot-name
+            (setf (slot-value wcomponent slot-name) new-value)
+            (if (null (wcomponent-allow-informal-parametersp wcomponent))
+                (error (format nil
+                               "Component ~a doesn't accept informal parameters"
+                               slot-initarg))
+                (setf (getf (wcomponent-informal-parameters wcomponent) initarg) new-value))))))
+
+
+(defun make-component (name parameters content)
+  "This function instantiates a wcomponent by the passed NAME, separetes parameters into formal(the ones that are the
+initarg of a slot, and informal parameters, that have their own slot in common. The CONTENT is the body content."
+  (let* ((instance (make-instance name))
+         (id (getf parameters :id))
+         (static-id (getf parameters :static-id))
+         (real-id (or static-id id)))
+    (setf (htcomponent-real-id instance) real-id)
+    (when static-id
+      (remf parameters :id))
+    (loop for (initarg value) on parameters by #'cddr
+       do (setf (slot-initialization instance initarg) value))
+    (setf (htcomponent-body instance) content)
+    instance))
+
+(defun build-component (component-name &rest rest)
+  "This function is the one that WCOMPONENT init functions call to intantiate their relative components.
+The REST parameter is flattened and divided into a pair, where the first element is the alist of the component parameters,
+while the second is the component body."
+  (let ((fbody (parse-htcomponent-function (flatten rest))))
+    (make-component component-name (first fbody) (second fbody))))
+
+(defmethod htcomponent-rewind ((wcomponent wcomponent) (page page))
+  (let ((template (wcomponent-template wcomponent)))
+    (wcomponent-before-rewind wcomponent page)
+    (if (listp template)
+        (dolist (tag template)
+          (htcomponent-rewind tag page))
+        (htcomponent-rewind template page))
+    (wcomponent-after-rewind wcomponent page)))
+
+(defmethod wcomponent-before-rewind ((wcomponent wcomponent) (page page)))
+(defmethod wcomponent-after-rewind ((wcomponent wcomponent) (page page)))
+
+(defmethod htcomponent-prerender ((wcomponent wcomponent) (page page))
+  (let ((render-condition (htcomponent-render-condition wcomponent)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (wcomponent-before-prerender wcomponent page)
+      (let ((previous-print-status (page-can-print page))
+            (template (wcomponent-template wcomponent)))
+        (when (null previous-print-status)
+          (setf (page-can-print page) (htcomponent-can-print wcomponent)))
+        (when (page-can-print page)
+          (let ((script-files (htcomponent-script-files wcomponent)))
+            (dolist (script (if (listp script-files)
+                                script-files
+                                (list script-files)))
+              (pushnew script (page-script-files page) :test #'equal)))
+          (let ((css-files (htcomponent-stylesheet-files wcomponent)))
+            (dolist (css (if (listp css-files)
+                             css-files
+                             (list css-files)))
+              (pushnew css (page-stylesheet-files page) :test #'equal)))
+          (dolist (js (htcomponent-class-initscripts wcomponent))
+            (pushnew js (page-class-initscripts page) :test #'equal))
+          (when (htcomponent-instance-initscript wcomponent)
+            (pushnew (htcomponent-instance-initscript wcomponent) (page-instance-initscripts page) :test #'equal)))
+        (if (listp template)
+            (dolist (tag template)
+              (when (subtypep (type-of tag) 'htcomponent)
+                (htcomponent-prerender tag page)))
+            (htcomponent-prerender template page))
+        (when (null previous-print-status)
+          (setf (page-can-print page) nil)))
+      (wcomponent-after-prerender wcomponent page))))
+
+(defmethod wcomponent-before-prerender ((wcomponent wcomponent) (page page)))
+(defmethod wcomponent-after-prerender ((wcomponent wcomponent) (page page)))
+
+(defmethod htcomponent-render ((wcomponent wcomponent) (page page))
+  (let ((template (wcomponent-template wcomponent))
+        (previous-print-status (page-can-print page))
+        (render-condition (htcomponent-render-condition wcomponent)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (when (null previous-print-status)
+        (setf (page-can-print page) (htcomponent-can-print wcomponent))
+        (htcomponent-json-print-start-component wcomponent))
+      (wcomponent-before-render wcomponent page)
+      (unless (listp template)
+        (setf template (list template)))
+      (dolist (child-tag template)
+        (when child-tag
+          (cond
+            ((stringp child-tag) (htcomponent-render ($> child-tag) page))
+            ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
+            (t (htcomponent-render child-tag page)))))
+      (wcomponent-after-render wcomponent page)
+      (when (null previous-print-status)
+        (setf (page-can-print page) nil)
+        (htcomponent-json-print-end-component wcomponent)))))
+
+(defmethod wcomponent-before-render ((wcomponent wcomponent) (page page)))
+(defmethod wcomponent-after-render ((wcomponent wcomponent) (page page)))
+
+(defclass error-page (page)
+  ((title :initarg :title
+	  :reader page-title
+	  :documentation "The page title")
+   (error-code :initarg :error-code
+	       :reader page-error-code
+	       :documentation "The error code to display"))
+  (:documentation "This is the page class used to render
+the http error messages."))
+
+(defclass error-page-template (wcomponent)
+  ((title :initarg :title
+	  :reader title
+	  :documentation "The page title")
+   (error-code :initarg :error-code
+	  :reader error-code
+	  :documentation "The http error code. For details consult http://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html")
+   (style :initarg :style
+	  :reader style
+	  :documentation "The CSS <style> element, used to beautify the error page."))
+  (:default-initargs :style "
+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;}" :empty t :allow-informal-parameters nil)
+  (:metaclass metacomponent)
+  (:documentation "The template for the error-page"))
+
+(let ((class (find-class 'error-page-template)))
+  (closer-mop:ensure-finalized class)
+  (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
+	(format nil "Description: ~a~%Parameters:~%~a~%~%~a"
+		"Function that instantiates an ERROR-PAGE-TEMPLATE component and renders a html tenplate for CLAW generic error pages."
+		(describe-html-attributes-from-class-slot-initargs class)
+		(describe-component-behaviour class))))
+
+(defmethod wcomponent-template ((error-page-template error-page-template))
+  (let ((error-code (error-code error-page-template))
+	(title (title error-page-template))
+	(style (style error-page-template))
+        (request-uri (connector-request-uri (clawserver-connector *clawserver*))))
+    (html>
+     (head>
+      (title> title)
+      (style> style))
+     (body>
+      (p>
+       (p> :class "h1"
+	   (format nil "HTTP Status ~a - ~a" error-code request-uri))
+       (hr> :noshade "noshade")
+       (p>
+	(span> :class "blue"
+	       ($> "type"))
+	"Status report")
+       (p>
+	(span> :class "blue"
+	       "url")
+	request-uri)
+       (p>
+	(span> :class "blue"
+	       "description")
+	(gethash error-code *http-reason-phrase-map*)
+	(hr> :noshade "noshade"))
+       (p> :class "h2"
+	   "claw server"))))))
+
+(defmethod page-content ((error-page error-page))
+  (let ((connector (clawserver-connector *clawserver*)))
+    (error-page-template> :title (page-title error-page)
+                          :error-code (page-error-code error-page)
+                          (format nil "The requested resource (~a) is not available." (connector-request-uri connector)))))
+
+(defun render-error-page (&optional (error-code 404))
+  "This function renders a http error page."
+  (let ((connector (clawserver-connector clawserver)))
+    (page-render (make-instance 'error-page
+                                :title (format nil "Server error: ~a" error-code)
+                                :error-code error-code))))
+#|
+(defmethod message-dispatch ((message-dispatcher message-dispatcher) key locale) nil)
+
+(defmethod message-dispatch ((i18n-aware i18n-aware) key locale)
+  (let ((dispatcher (message-dispatcher i18n-aware))
+        (result))
+    (when dispatcher
+      (progn
+        (setf result (message-dispatch dispatcher key locale))
+        (when (and (null result) (> (length locale) 2))
+          (setf result (message-dispatch dispatcher key (subseq locale 0 2))))))
+    result))
+
+(defmethod simple-message-dispatcher-add-message ((simple-message-dispatcher simple-message-dispatcher) locale key value)
+  (let ((current-locale (gethash locale (simple-message-dispatcher-locales simple-message-dispatcher) (make-hash-table :test #'equal))))
+    (setf (gethash key current-locale) value)
+    (setf (gethash locale (simple-message-dispatcher-locales simple-message-dispatcher)) current-locale)))
+
+(defmethod message-dispatch ((simple-message-dispatcher simple-message-dispatcher) key locale)
+  (let ((current-locale (gethash locale (simple-message-dispatcher-locales simple-message-dispatcher))))
+    (when current-locale
+      (gethash key current-locale))))
+|#

Added: trunk/main/claw-html/src/translators.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-html/src/translators.lisp	Fri Jul 25 11:09:52 2008
@@ -0,0 +1,338 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/translators.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-html)
+
+(defgeneric translator-encode (translator wcomponent)
+  (:documentation "Encodes the input component value, used when rendering the component (Encodes from type to string)."))
+
+(defgeneric translator-type-to-string (translator wcomponent)
+  (:documentation "Encodes the input component value, used when rendering the component (Encodes from type to string). It's a wrapper for translator-encode"))
+
+(defgeneric translator-decode (translator wcomponent)
+  (:documentation "Decodes the input component value after a form submit (Decodes from string to type)."))
+
+(defgeneric translator-string-to-type (translator wcomponent)
+  (:documentation "Decodes the input component value after a form submit (Decodes from string to type). It's a wrapper for translator-decode"))
+
+(defgeneric translator-value-encode (translator value)
+  (:documentation "Encodes the value, used when rendering the component (Encodes from type to string)."))
+
+(defgeneric translator-value-type-to-string (translator value)
+  (:documentation "Encodes the value, used when rendering the component (Encodes from type to string). It's a wrapper for translator-value-encode"))
+
+(defgeneric translator-value-decode (translator value &optional client-id label)
+  (:documentation "Decodes value after a form submit (Decodes from string to type)."))
+
+(defgeneric translator-value-string-to-type (translator value &optional client-id label)
+  (:documentation "Decodes value after a form submit (Decodes from string to type). It's a wrapper for translator-value-decode"))
+
+(defclass translator ()
+  ((validation-error-control-string :initarg :validation-error-control-string
+                                    :reader validation-error-control-string
+                                    :documentation "Control string that accepts a label attribute"))
+  (:documentation "a translator object encodes and decodes values passed to a html input component")
+  (:default-initargs :validation-error-control-string nil))
+
+(defmethod translator-value-encode ((translator translator) value)
+  (format nil "~a" value))
+
+(defmethod translator-value-type-to-string ((translator translator) value)
+  (translator-value-encode translator value))
+
+(defmethod translator-encode ((translator translator) (wcomponent base-cinput))
+  (let* ((page (htcomponent-page wcomponent))
+         (visit-object (or (cinput-visit-object wcomponent) page))
+         (accessor (cinput-accessor wcomponent))
+         (reader (cinput-reader wcomponent))
+         (value (page-req-parameter page (name-attr wcomponent) nil)))
+    (if (component-validation-errors wcomponent)
+        value
+        (progn
+          (setf value (cond
+                        ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
+                        (t (funcall (fdefinition reader) visit-object))))
+          (translator-value-encode translator value)))))
+
+(defmethod translator-type-to-string ((translator translator) (wcomponent cinput))
+  (translator-encode translator wcomponent))
+
+(defmethod translator-value-decode ((translator translator) value &optional client-id label)
+  (declare (ignore client-id label))
+  value)
+
+(defmethod translator-value-string-to-type ((translator translator) value &optional client-id label)
+  (translator-value-decode translator value client-id label))
+
+(defmethod translator-decode ((translator translator) (wcomponent wcomponent))
+  (multiple-value-bind (client-id value)
+      (component-id-and-value wcomponent)
+    (translator-value-decode translator value client-id (label wcomponent))))
+
+(defmethod translator-string-to-type ((translator translator) (wcomponent wcomponent))
+  (translator-decode translator wcomponent))
+
+(setf *simple-translator* (make-instance 'translator))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;; Integer translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass translator-integer (translator)
+  ((thousand-separator :initarg :thousand-separator
+                       :reader translator-thousand-separator
+                       :documentation "If specified (as character), it is the thousands separator. Despite of
+its name, grouping is done following the TRANSLATOR-GROUPING-SIZE, so it's not a real 'tousands' separator")
+   (always-show-signum :initarg :always-show-signum
+                       :reader translator-always-show-signum
+                       :documentation "When true the signum is used also for displaying positive numbers.")
+   (grouping-size :initarg :grouping-size
+                  :reader translator-grouping-size
+                  :documentation "Used only if TRANSLATOR-THOUSAND-SEPARATOR is defined. Default to 3"))
+  (:default-initargs :thousand-separator nil
+    :grouping-size 3
+    :always-show-signum nil)
+  (:documentation "A translator object encodes and decodes integer values passed to a html input component"))
+
+(defmethod translator-value-encode ((translator translator-integer) value)
+  (let* ((grouping-size (translator-grouping-size translator))
+         (thousand-separator (translator-thousand-separator translator))
+         (signum-directive (if (translator-always-show-signum translator)
+                               "@"
+                               ""))
+         (control-string (if thousand-separator
+                             (format nil "~~~d,',v:~aD" grouping-size signum-directive)
+                             (format nil "~~~ad"  signum-directive))))
+    (if thousand-separator
+        (string-trim " " (format nil control-string thousand-separator value))
+        (format nil control-string value))))
+
+(defmethod translator-value-decode ((translator translator-integer) value &optional client-id label)
+  (let ((thousand-separator (translator-thousand-separator translator)))
+    (handler-case
+        (if thousand-separator
+            (parse-integer (regex-replace-all (format nil "~a" thousand-separator) value ""))
+            (parse-integer value))
+      (error () (progn
+                  (when label
+                    (add-validation-error client-id (format nil (or (validation-error-control-string translator)
+                                                                    "Field ~a is not a valid integer.") label)))
+                  value)))))
+
+(defvar *integer-translator* (make-instance 'translator-integer))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;Folating point number translator ;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass translator-number (translator-integer)
+  ((decimals-separator :initarg :decimals-separator
+                       :reader translator-decimals-separator
+                       :documentation "The decimal separator of the rendered number. Default to #\.")
+   (decimal-digits :initarg :decimal-digits
+                   :reader translator-decimal-digits
+                   :documentation "force the rendering of the value to a fixed number of decimal digits")
+   (coerce :initarg :coerce
+           :accessor translator-coerce
+           :documentation "Coerces the decoded input value to the given value type"))
+  (:default-initargs :decimals-separator #\.
+    :decimal-digits nil
+    :coerce 'ratio)
+  (:documentation "a translator object encodes and decodes integer values passed to a html input component"))
+
+
+(defmethod translator-value-encode ((translator translator-number) value)
+  (let* ((thousand-separator (translator-thousand-separator translator))
+         (grouping-size (translator-grouping-size translator))
+         (decimal-digits (translator-decimal-digits translator))
+         (decimals-separator (translator-decimals-separator translator))
+         (signum-directive (if (translator-always-show-signum translator) "@" ""))
+         (integer-control-string (if thousand-separator
+                                     (format nil "~~~d,',v:~aD"  grouping-size signum-directive)
+                                     (format nil "~~~ad"  signum-directive))))
+    (multiple-value-bind (int-value dec-value)
+        (floor value)
+      (setf dec-value (coerce dec-value 'float))
+      (format nil "~a~a"
+              (if thousand-separator
+                  (string-trim " " (format nil integer-control-string thousand-separator int-value))
+                  (format nil integer-control-string int-value))
+              (cond
+                ((and (= 0.0 (coerce dec-value 'double-float)) decimal-digits)
+                 (format nil "~a~a" decimals-separator (make-string decimal-digits :initial-element #\0)))
+                (decimal-digits
+                 (let ((frac-part (subseq (format nil "~f" dec-value) 2)))
+                   (if (> (length frac-part) decimal-digits)
+                       (setf frac-part (subseq frac-part 0 decimal-digits))
+                       (setf frac-part (concatenate 'string frac-part (make-string (- decimal-digits (length frac-part)) :initial-element #\0))))
+                   (format nil "~a~a" decimals-separator frac-part)))
+                (t (format nil "~a~a" decimals-separator (subseq (format nil "~f" dec-value) 2))))))))
+
+(defmethod translator-value-decode ((translator translator-number) value &optional client-id label)
+  (let ((thousand-separator (translator-thousand-separator translator))
+        (type (translator-coerce translator))
+        (new-value))
+    (if thousand-separator
+        (setf new-value (regex-replace-all (format nil "~a" thousand-separator) value ""))
+        (setf new-value value))
+    (handler-case
+        (let* ((decomposed-string (all-matches-as-strings "[0-9]+" new-value))
+               (int-value (parse-integer (concatenate 'string (first decomposed-string) (second decomposed-string))))
+               (dec-value (expt 10 (length (second decomposed-string))))
+               (result (/ int-value dec-value)))
+          (if (integerp result)
+              result
+              (coerce result type)))
+      (error () (progn
+                  (when label
+                    (add-validation-error client-id (format nil (or (validation-error-control-string translator)
+                                                                    "Field ~a is not a valid number.") label)))
+                  value)))))
+
+
+(defvar *number-translator* (make-instance 'translator-number))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;; Dates translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass translator-date (translator)
+  ((local-time-format :initarg :local-time-format
+                      :reader translator-local-time-format
+                      :documentation "Sets the format of a date using a list where element are joined together and :DATE :MONTH and :YEAR are
+expanded into day of the month for :DATE, month number for :MONTH and the year for :YEAR. The Default is the list '(:month \"/\" :date \"/\" :year)"))
+  (:default-initargs :local-time-format '(:year "-" :month "-" :date))
+  (:documentation "A translator object encodes and decodes local-date object value passed to a html input component.
+When decoding the input compoenent value string to a local-time instance
+if the date is expressed in a wrong format or is not valid, a localizable message \"Field ~a is not a valid date or wrong format: ~a\" is sent with key \"VALIDATE-DATE\".
+The argument for the message will be the :label attribute of the COMPONENT and the input component string value."))
+
+
+
+(defmethod translator-value-encode ((translator translator-date) value)
+  (let* ((local-time-format (translator-local-time-format translator)))
+    (if (and value (not (stringp value)))
+        (local-time-to-string value local-time-format)
+        value)))
+
+(defmethod translator-value-decode ((translator translator-date) value &optional client-id label)
+  (let ((date-format (translator-local-time-format translator))
+        (sec 0)
+        (min 0)
+        (hour 0)
+        (day 1)
+        (month 1)
+        (year 0)
+        (old-value))
+    (when (and value (string-not-equal value ""))
+      (setf old-value value)
+      (loop for element in date-format
+         do (if (stringp element)
+                (setf value (subseq value (length element)))
+                (ccase element
+                  (:second (multiple-value-bind (curr-value size)
+                               (parse-integer value :junk-allowed t)
+                             (setf value (subseq value size))
+                             (setf sec curr-value)))
+                  (:minute (multiple-value-bind (curr-value size)
+                               (parse-integer value :junk-allowed t)
+                             (setf value (subseq value size))
+                             (setf min curr-value)))
+                  (:hour (multiple-value-bind (curr-value size)
+                             (parse-integer value :junk-allowed t)
+                           (setf value (subseq value size))
+                           (setf hour curr-value)))
+                  (:date (multiple-value-bind (curr-value size)
+                             (parse-integer value :junk-allowed t)
+                           (setf value (subseq value size))
+                           (setf day curr-value)))
+                  (:month (multiple-value-bind (curr-value size)
+                              (parse-integer value :junk-allowed t)
+                            (setf value (subseq value size))
+                            (setf month curr-value)))
+                  (:year (multiple-value-bind (curr-value size)
+                             (parse-integer value :junk-allowed t)
+                           (setf value (subseq value size))
+                           (setf year curr-value))))))
+      (if (and (string-equal value "")
+               (>= sec 0)
+               (>= min 0)
+               (>= hour 0)
+               (and (> month 0) (<= month 12))
+               (and (> day 0) (<= day (days-in-month month year))))
+          (encode-local-time 0 sec min hour day month year)
+          (progn
+            (when label
+              (add-validation-error client-id (format nil (or (validation-error-control-string translator)
+                                                              "Field ~a is not a valid date or wrong format.") label)))
+            value)))))
+
+(defvar *date-translator-ymd* (make-instance 'translator-date))
+
+(defvar *date-translator-time* (make-instance 'translator-date :local-time-format '("T" :hour ":" :minute ":" :second)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;; Boolean translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass translator-boolean (translator)
+  ()
+  (:documentation "a translator object encodes and decodes boolean values passed to a html input component"))
+
+(defmethod translator-value-encode ((translator translator-boolean) value)
+  (format nil "~a" value))
+
+(defmethod translator-value-decode ((translator translator-boolean) value &optional client-id label)
+  (declare (ignore client-id label))
+  (if (string-equal value "NIL")
+      nil
+      t))
+
+(defvar *boolean-translator* (make-instance 'translator-boolean))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;; File translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass translator-file (translator)
+  ()
+  (:documentation "a translator object encodes and decodes file values passed to a html input component of type file"))
+
+(defmethod translator-value-encode ((translator translator-file) value)
+  (cond
+    ((null value) "")
+    ((stringp value) value)
+    ((pathnamep value) (format nil "~a.~a"
+                               (pathname-name value)
+                               (pathname-type value)))
+    (t (second value))))
+
+(defmethod translator-value-decode ((translator translator-file) value &optional client-id label)
+  (declare (ignore client-id label))
+  value)
+
+(setf *file-translator* (make-instance 'translator-file))
\ No newline at end of file

Added: trunk/main/claw-html/src/validators.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-html/src/validators.lisp	Fri Jul 25 11:09:52 2008
@@ -0,0 +1,225 @@
+;;; -*- 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-html)
+
+(defgeneric local-time-to-string (local-time format)
+  (:documentation "Writes a local-time instance the FORMAT list where element are joined together and :SECOND :MINUTE :HOUR :DATE :MONTH and :YEAR are
+expanded into seconds for :SECOND, minutes for :MINUTE, hour of the day for :HOUR, day of the month for :DATE, month number for :MONTH and the year for :YEAR.
+A format list may be for example '(:month \"/\" :date \"/\" :year)"))
+
+(defmethod local-time-to-string ((local-time local-time) format)
+  (multiple-value-bind (nsec sec min hour day month year)
+      (decode-local-time local-time)
+    (declare (ignore nsec))
+    (loop for result = "" then (concatenate 'string result (if (stringp element)
+                                                               element
+                                                               (ccase element
+                                                                 (:second (format nil "~2,'0D" sec))
+                                                                 (:minute (format nil "~2,'0D" min))
+                                                                 (:hour (format nil "~2,'0D" hour))
+                                                                 (:date (format nil "~2,'0D" day))
+                                                                 (:month (format nil "~2,'0D" month))
+                                                                 (:year (format nil "~4,'0D" year)))))
+       for element in format
+       finally (return result))))
+
+(defun add-validation-error (id reason)
+  "Adds an exception for the given input component identified by its ID with the message expressed by REASON"
+  (let* ((symbol-id (intern id))
+         (errors (getf *validation-errors* symbol-id)))
+    (setf (getf *validation-errors* symbol-id) (nconc errors (list reason)))))
+
+(defun component-exceptions (id)
+  "Returns a list of exception connectd to the given component"
+  (let ((symbol-id (intern id)))
+    (getf *validation-errors* symbol-id)))
+
+(defun validate (test &key component message)
+  "When test is nil, an exception message given by MESSAGE is added for the COMPONENT. See: ADD-VALIDATION-ERROR..."
+  (let ((client-id (htcomponent-client-id component)))
+    (if test
+        (add-validation-compliance client-id)
+        (add-validation-error client-id message))))
+
+(defun validate-required (component value &key message)
+  "Checks if the required input field VALUE is present.  If not, a localizable message \"Field ~a may not be empty.\" is sent with key \"VALIDATE-REQUIRED\".
+The argument for the message will be the :label attribute of the COMPONENT."
+  (when (stringp value)
+    (validate (and value (string-not-equal value ""))
+              :component component
+              :message (or message (format nil "Field ~a may not be empty." (label component))))))
+
+(defun validate-size (component value &key min-size max-size message-low message-hi)
+  "Checks if the input field VALUE legth is less then or greater then rispectively of the form keywords :MIN-SIZE and :MAX-SIZE.
+If less then :MIN-SIZE, a localizable message \"Size of ~a may not be less then ~a chars.\" is sent with key \"VALIDATE-SIZE-MIN\".
+The argument for the message will be the :label attribute of the COMPONENT and the :MIN-ZIZE value.
+If greater then :MAX-SIZE, a localizable message \"Size of ~a may not be more then ~a chars\" is sent with key \"VALIDATE-SIZE-MAX\".
+The argument for the message will be the :label attribute of the COMPONENT and the :MAX-ZIZE value."
+  (let ((value-len 0))
+    (when value
+      (setf value (format nil "~a" value))
+      (setf value-len (length value))
+      (and (= value-len 0)
+           (when min-size
+             (validate (>= value-len min-size)
+                       :component component
+                       :message (or message-low (format nil "Size of ~a may not be less then ~a chars."
+                                                        (label component)
+                                                        min-size))))
+           (when max-size
+             (validate (<= value-len max-size)
+                       :component component
+                       :message (or message-hi (format nil "Size of ~a may not be more then ~a chars."
+                                                       (label component)
+                                                       max-size))))))))
+
+(defun validate-range (component value &key min max message-low message-hi)
+  "Checks if the numeric input field VALUE is less then or greater then rispectively of the form keywords :MIN and :MAX.
+If less then :MIN, a localizable message \"Field ~a is not less then or equal to ~d.\" is sent with key \"VALIDATE-RANGE-MIN\".
+The argument for the message will be the :label attribute of the COMPONENT and the :MIN value.
+If greater then :MIN, a localizable message \"Field ~a is not greater then or equal to ~d.\" is sent with key \"VALIDATE-RANGE-MAX\".
+The argument for the message will be the :label attribute of the COMPONENT and the :MAX value."
+  (when value
+    (and (when min
+           (validate (>= value min)
+                     :component component
+                     :message (or message-low (format nil "Field ~a is not greater then or equal to ~d"
+                                                      (label component)
+                                                      (if (typep min 'ratio)
+                                                          (coerce min 'float)
+                                                          min)))))
+         (when max
+           (validate (<= value max)
+                     :component component
+                     :message (or message-hi (format nil "Field ~a is not less then or equal to ~d"
+                                                     (label component)
+                                                     (if (typep max 'ratio)
+                                                         (coerce max 'float)
+                                                         max))))))))
+
+(defun validate-number (component value &key min max message-nan message-low message-hi)
+  "Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE.
+If not a number, a localizable message \"Field ~a is not a valid number.\" is sent with key \"VALIDATE-NUMBER\".
+The argument for the message will be the :label attribute of the COMPONENT."
+  (when value
+    (let ((test (numberp value)))
+      (and (validate test
+                     :component component
+                     :message (or message-nan (format nil "Field ~a is not a valid number." (label component))))
+           (validate-range component value :min min :max max :message-low  message-low :message-hi message-hi)))))
+
+(defun validate-integer (component value &key min max message-nan message-low message-hi)
+  "Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE.
+If not a number, a localizable message \"Field ~a is not a valid integer.\" is sent with key \"VALIDATE-INTEGER\".
+The argument for the message will be the :label attribute of the COMPONENT."
+  (when value
+    (let ((test (integerp value)))
+      (and (validate test
+                     :component component
+                     :message (or message-nan (format nil "Field ~a is not a valid integer." (label component))))
+           (validate-range component value :min min :max max :message-low  message-low :message-hi message-hi)))))
+
+
+(defun validate-date-range (component value &key min max (use-date-p t) use-time-p message-low message-hi)
+  "Checks if the input field VALUE is a date between min and max.
+If :USE-DATE-P is not nil and :USE-TIME-P is nil, validation is made without considering the time part of local-time.
+If :USE-DATE-P nil and :USE-TIME-P is not nil, validation is made without considering the date part of local-time.
+If :USE-DATE-P and :USE-TIME-P are both not nil or nil, validation is made considering the date and time part of local-time.
+If value is less then the date passed to :MIN, a localizable message \"Field ~a is less then ~a.\" is sent with key \"VALIDATE-DATE-RANGE-MIN\".
+The argument for the message will be the :label attribute of the COMPONENT and the value passed to :MIN parsed with the :LOCAL-TIME-FORMAT keyword.
+If value is greater then the date passed to :MAX, a localizable message \"Field ~a is greater then ~a.\" is sent with key \"VALIDATE-DATE-RANGE-MAX\".
+The argument for the message will be the :label attribute of the COMPONENT and the value passed to :MAX parsed with the :LOCAL-TIME-FORMAT keyword."
+  (unless (component-validation-errors component)
+    (let ((local-time-format '(:date "-" :month "-" :year))
+          (new-value (make-instance 'local-time
+                                    :nsec (nsec-of value)
+                                    :sec (sec-of value)
+                                    :day (day-of value)
+                                    :timezone (timezone-of value))))
+      (when (and use-date-p (not use-time-p))
+        (setf (local-time:nsec-of new-value) 0
+              (local-time:sec-of new-value) 0)
+        (when min
+          (setf (local-time:nsec-of min) 0
+                (local-time:sec-of min) 0))
+        (when max
+          (setf (local-time:nsec-of max) 0
+                (local-time:sec-of max) 0)))
+      (when (and (not use-date-p) use-time-p)
+        (setf (local-time:day-of new-value) 0)
+        (when min
+          (setf (local-time:day-of min) 0))
+        (when max
+          (setf (local-time:day-of max) 0)))
+      (and (when min
+             (validate (local-time> new-value min)
+                       :component component
+                       :message (or message-low (format nil "Field ~a is less then ~a."
+                                                        (label component)
+                                                        (local-time-to-string min local-time-format)))))
+           (when max
+             (validate (local-time< new-value max)
+                       :component component
+                       :message (or message-hi (format nil "Field ~a is greater then ~a."
+                                                       (label component)
+                                                       (local-time-to-string max local-time-format)))))))))
+
+
+
+;; ------------------------------------------------------------------------------------
+(defclass exception-monitor (wcomponent) ()
+  (:metaclass metacomponent)
+  (:default-initargs :json-render-on-validation-errors-p t)
+  (:documentation "If from submission contains exceptions. It displays exception messages"))
+
+(let ((class (find-class 'exception-monitor)))
+  (closer-mop:ensure-finalized class)
+  (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
+        (format nil "Description: ~a~%Parameters:~%~a~a~%~%~a"
+                "If from submission contains exceptions. It displays exception messages with a <ul> list"
+                *id-and-static-id-description*
+                (describe-html-attributes-from-class-slot-initargs class)
+                (describe-component-behaviour class))))
+
+(defmethod wcomponent-template ((exception-monitor exception-monitor))
+  (let ((client-id (htcomponent-client-id exception-monitor))
+        (body (htcomponent-body exception-monitor)))
+    (div> :static-id client-id
+          (wcomponent-informal-parameters exception-monitor)
+          (when *validation-errors*
+            (if body
+                body
+                (ul> :id "errors"
+                     (loop for (client-id component-exceptions) on *validation-errors* by #'cddr
+                        collect (loop for message in component-exceptions
+                                   collect (li> message)))))))))
+
+
+;;-------------------------------------------------------------------------------------------

    

[claw-cvs] r66 - in trunk/main/claw-html: . src

achiumenti＠common-lisp.net