[claw-cvs] r66 - in trunk/main/claw-html: . src
achiumenti at common-lisp.net
achiumenti at common-lisp.net
Fri Jul 25 15:09:57 UTC 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 , at 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)))))))))
+
+
+;;-------------------------------------------------------------------------------------------
More information about the Claw-cvs
mailing list