;;; -*- 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-before-render (page)
  (:documentation "This method is called as first instruction of PAGE-RENDER.
 - 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-initscripts (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. The result is used by the HTBODY-INITSCRIPTS-TAG method 
that generates a <script> tag that will be appended at the end of the <body> tag (generated by the BODY> function
tag.
 - PAGE is the page instance that must be given
"))

(defgeneric htbody-initscripts-tag (page &optional on-load)
  (:documentation "Encloses the init inscance scripts injected into the page into a <script> tag component
See PAGE-BODY-INITSCRIPTS 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-created (wcomponent)
  (:documentation "Method called just before the make-component function exits. Do additional instance initialization here.
"))

(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 *rewind-form-parameter* "rewindformobject"
  "The request parameter name for the form curently rewinding")

(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 *calw-this-component* nil
  "Variable set when rendering a WCOMPONENT-TEMPLATE so it is accessible inside the template")

(defvar *id-table-map* (make-hash-table :test 'equal)
  "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\".")

(defstruct list-for-tag-attribute
  "Since tag attributes values are flattened, it is impossible to pass lists as values. Use this struct to pass lists to values
"
  (value nil))

(defun attribute-value (value)
  "Creates an unflattenable value for tag attributes. This is particularly useful when you need to pass a list as an attribute value
"
  (make-list-for-tag-attribute :value value))

(defmacro when-let ((var form) &body body)
           `(let ((,var ,form))
              (when ,var ,@body)))

(defmacro listify (var)
  `(if (listp ,var)
       ,var
       (list ,var)))

(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 (or (when (list-for-tag-attribute-p elem) 
                          (list-for-tag-attribute-value elem)) 
                        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))
         (claw-type (getf attributes :clawtype))
         (real-id (or static-id id))
         (instance))
    (when static-id
      (remf attributes :id)
      (setf id nil))
    (when render-condition
      (remf attributes :render-condition))
    (if claw-type
      (let (clawtype-sybol-list (split "([:]){1,2}" (string-upcase claw-type)))
        (if (second clawtype-sybol-list)
            (setf claw-type (find-symbol (second clawtype-sybol-list)
                                         (first clawtype-sybol-list)))
            (setf claw-type (find-symbol (first clawtype-sybol-list))))
        (make-component claw-type attributes (second fbody)))
      (progn
        (setf instance (make-instance (or claw-type 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 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")
   (global-initscripts :initarg :global-initscripts
                      :accessor page-global-initscripts :documentation "Holds component class javascript directives injected by components during the request cycle")
   (initscripts :initarg :initscripts
                :accessor page-initscripts :documentation "Holds component instance javascript directives injected by components during the request cycle")
   (initstyles :initarg :initstyles
               :accessor page-initstyles :documentation "Holds component class and instance stylesheet 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 Transitional)")
   (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")
   (teamplate :initarg :template
              :accessor template
              :documentation "A lambda function with no parameters that, when not nil, is used as page-content."))
  (:default-initargs :writer t
    :external-format-encoding :utf-8
    :script-files nil
    :json-component-count 0
    :stylesheet-files nil
    :global-initscripts nil
    :initscripts nil
    :initstyles nil
    :indent t
    :tabulator 0
    :xmloutput nil
    :doc-type *html-4.01-transitional*
    :request-parameters nil
    :template nil
    :mime-type "text/html")
  (:documentation "A page object holds claw components to be rendered") )

(defmethod page-content ((page page))
  (when-let (lambda-content (template page))
    (funcall lambda-content)))

(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 (if (functionp http-post-parameters)
                                                                  (funcall http-post-parameters)
                                                                  http-post-parameters) 
                                             :get-parameters (if (functionp http-get-parameters)
                                                                 (funcall http-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.
If the value is T then component will be rendered on any error, if it's a tag id string it will be rendere only when the rewind parameter will match
")
   (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")
   (global-initscripts :initarg :global-initscripts
                      :accessor htcomponent-global-initscripts :documentation "Page injectable javascript class derectives")
   (initscripts :initarg :initscripts
                :accessor htcomponent-initscripts :documentation "Page injectable javascript instance derectives. It may be a string or a list of strings")
   (initstyles :initarg :initstyles
                     :accessor htcomponent-initstyles :documentation "Component injectable css derectives. It may be a string or a list of strings"))
  (: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
    :global-initscripts nil
    :initscripts nil
    :initstyles 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"))

(defclass htignore (htcomponent)
  ()
  (:documentation "Ignore all content"))



(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))

(defun ignore> (&rest ignore)
  "Creates an ignore content"
  (declare (ignore ignore))
  (make-instance 'htignore))

(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))
  (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-before-render ((page page))
  nil)

(defmethod page-render ((page page))
  (let ((*claw-current-page* page)
        (*id-table-map* (make-hash-table :test 'equal))
        (*validation-errors* nil)
        (*validation-compliances* nil)
        (jsonp (page-json-id-list page)))
    (page-init page)
    (page-before-render page)
    (when (page-req-parameter page *rewind-parameter*)
      (htcomponent-rewind (page-content page) 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-initscripts-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-initscripts ((page page))
  (when-let (init-scripts (reverse (page-initscripts page)))
    (format nil "~{~a~%~}" init-scripts)))

(defmethod page-print-tabulation ((page page))
  (let ((tabulator (page-tabulator page))
        (indent-p (page-indent page)))
    (when (and (<= 0 tabulator) indent-p)
      (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 (format nil "~{~a~%~}" (reverse (page-global-initscripts page))))
        (init-styles (format nil "~{~a~%~}" (reverse (page-initstyles page)))))    
    (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))))
    (unless (string= "" init-styles)
      (let ((current-css (style> :type "text/css")))
        (setf (htcomponent-body current-css) (list "\
" init-styles))
        (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-value (htcomponent-json-render-on-validation-errors-p htcomponent))
         (json-render-on-validation-errors-p (if (typep json-render-on-validation-errors-value 'boolean)
                                                 json-render-on-validation-errors-value
                                                 (string= json-render-on-validation-errors-value
                                                          (page-req-parameter *claw-current-page* *rewind-parameter*))))
         (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*)
         (json-render-on-validation-errors-value (htcomponent-json-render-on-validation-errors-p htcomponent))
         (json-render-on-validation-errors-p (if (typep json-render-on-validation-errors-value 'boolean)
                                                 json-render-on-validation-errors-value
                                                 (string= json-render-on-validation-errors-value
                                                          (page-req-parameter *claw-current-page* *rewind-parameter*)))))
    (when (and jsonp
               (or (and (null validation-errors)
                        (member id jsonp :test #'string-equal))
                   json-render-on-validation-errors-p))
      (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*)
         (json-render-on-validation-errors-value (htcomponent-json-render-on-validation-errors-p htcomponent))
         (json-render-on-validation-errors-p (if (typep json-render-on-validation-errors-value 'boolean)
                                                 json-render-on-validation-errors-value
                                                 (string= json-render-on-validation-errors-value
                                                          (page-req-parameter *claw-current-page* *rewind-parameter*)))))
    (when (and jsonp
               (or (and (null validation-errors)
                        (member id jsonp :test #'string-equal))
                   json-render-on-validation-errors-p))
      (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))
            ((null child-tag) nil)
            (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)))))))
      (decf (page-tabulator page))
      (if (string= tagname previous-tagname)
          (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))
            ((null child-tag) nil)
            (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))
                ((null child-tag) nil)
                (t (htcomponent-render child-tag page)))))
          (dolist (injection injections)
            (when injection
              (htcomponent-render injection page)))
          (tag-render-endtag hthead page))))))

;;;========= HTIGNORE ===================================
(defmethod htcomponent-rewind((htignore htignore) (page page)))
(defmethod htcomponent-prerender((htignore htignore) (page page)))
(defmethod htcomponent-render ((htignore htignore) (page 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 "&#60;"))
                    ((#\>) (page-format-raw page "&#62;"))
                    ((#\&) (page-format-raw page "&#38;"))
                    (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))
                ((null element) nil)
                (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 "stylesheet") (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))
            ((null child-tag) nil)
            (t (htcomponent-render child-tag page)))))
      (when (page-can-print page)
        (when-let (init-script-tag (htbody-initscripts-tag page t))
          (htcomponent-render init-script-tag 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-initscripts-tag ((page page) &optional on-load)
  (when-let (scripts (page-body-initscripts page))
    (let ((js (script> :type "text/javascript"))
          (js-control-string (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~%")))
      (setf (htcomponent-page js) page
            (htcomponent-body js) (format nil
                                          js-control-string
                                          scripts))
      js)))

;;;========= WCOMPONENT ===================================

(defgeneric wcomponent-allow-informal-parametersp (wcomponent)
  (:documentation "Returns T if the component accepts informal parameters for the generated tag function.
Informal parameters are the ones not defined as slot initargs for the wcomponent.
"))

(defgeneric wcomponent-informal-parameters (wcomponent)
  (:documentation "Informal parameters are parameters optional for the component and not defined as slot initargs.
"))

(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")
   (teamplate :initarg :template
              :accessor template
              :documentation "A lambda function with no parameters that, when not nil, is used as page-content. *CLAW-THIS-COMPONENT* is set as a closure, so that may be directly used inside the template."))
  (: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."))

(defmethod wcomponent-template ((wcomponent wcomponent))
  (let ((*claw-this-component* wcomponent))
    (when-let (lambda-content (template page))
      (funcall lambda-content))))

(defmethod wcomponent-created ((wcomponent wcomponent))
  nil)

(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 for component ~a is reserved" initarg (type-of wcomponent)))
        (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"
                               (type-of wcomponent)))
                (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."
  (remf :clawtype parameters)
  (unless (or (getf parameters :id) 
              (getf parameters :static-id))
    (setf (getf parameters :id) "claw"))
  (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)
    (wcomponent-created instance)
    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* ((current-form (page-current-form page))
         (call-rewind-methods-p (and (null *validation-errors*)
                                     current-form
                                     (string= (htcomponent-client-id current-form) (page-req-parameter page *rewind-parameter*)))))
    (when call-rewind-methods-p
      (wcomponent-before-rewind wcomponent page))
    (let ((template (wcomponent-template wcomponent)))
      (if (listp template)
          (dolist (tag template)
            (htcomponent-rewind tag page))
          (htcomponent-rewind template page)))
    (when call-rewind-methods-p
      (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)
          (dolist (css (listify (htcomponent-stylesheet-files wcomponent)))
            (pushnew css (page-stylesheet-files page) :test #'equal))
          (dolist (js (listify (htcomponent-script-files wcomponent)))
            (pushnew js (page-script-files page) :test #'equal))
          (dolist (js (listify (htcomponent-global-initscripts wcomponent)))
            (pushnew js (page-global-initscripts page) :test #'equal))
          (dolist (js (listify (htcomponent-initscripts wcomponent)))
            (pushnew js (page-initscripts page) :test #'equal))
          (dolist (style (listify (htcomponent-initstyles wcomponent)))
            (pushnew style (page-initstyles 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))
            ((null child-tag) nil)
            (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)))