Author: achiumenti Date: Sat Jun 14 01:16:01 2008 New Revision: 50 Modified: trunk/main/claw-core/src/components.lisp trunk/main/claw-core/src/lisplet.lisp trunk/main/claw-core/src/misc.lisp trunk/main/claw-core/src/packages.lisp trunk/main/claw-core/src/server.lisp trunk/main/claw-core/src/tags.lisp trunk/main/claw-core/src/translators.lisp trunk/main/claw-core/tests/test1.lisp Log: a lot of bug fixes. Modified: trunk/main/claw-core/src/components.lisp ============================================================================== --- trunk/main/claw-core/src/components.lisp (original) +++ trunk/main/claw-core/src/components.lisp Sat Jun 14 01:16:01 2008 @@ -33,9 +33,9 @@ (: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. + (: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 translator-encode (translator wcomponent) @@ -68,15 +68,18 @@ (defgeneric name-attr (cinput) (:documentation "Returns the name of the input component")) -(defclass translator () +(defclass translator () () (:documentation "a translator object encodes and decodes values passed to a html input component")) (defvar *simple-translator* nil - "*SIMPLE-TRANSLATOR* is the default translator for any CINPUT component. + "*SIMPLE-TRANSLATOR* is the default translator for any CINPUT component. Its encoder and decoder methods pass values unchanged") -(defun component-validation-errors (component &optional (request *request*)) +(defvar *file-translator* nil + "*FILE-TRANSLATOR* is the default translator for any CINPUT component of type \"file\".") + +(defun component-validation-errors (component &optional (request *request*)) "Resurns possible validation errors occurred during form rewinding bound to a specific component" (let ((client-id (htcomponent-client-id component))) (getf (validation-errors request) (intern client-id)))) @@ -85,14 +88,35 @@ -(defclass cform (wcomponent) +(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")) - (:default-initargs :action nil :class nil) + :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")) @@ -107,13 +131,10 @@ (describe-component-behaviour class)))) -(defmethod cform-rewinding-p ((cform cform) (page page)) - (string= (htcomponent-client-id cform) - (page-req-parameter page *rewind-parameter*))) - (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 "")) @@ -121,26 +142,40 @@ (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" + :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-rewind ((obj cform) (pobj page)) - (let ((validation-errors (validation-errors)) - (action (action obj))) - (unless validation-errors - (when (or action (cform-rewinding-p obj pobj)) - (funcall action pobj)) - (setf (page-current-form pobj) nil)))) +(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) () +(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. @@ -165,11 +200,12 @@ (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") + :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") @@ -179,7 +215,7 @@ (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 + (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 @@ -209,7 +245,7 @@ (defclass cinput (base-cinput) ((input-type :initarg :type :reader input-type - :documentation "The html <input> TYPE attribute. For submit type, use the CSUBMIT> function.")) + :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")) @@ -218,13 +254,13 @@ (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." + "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)) +(defmethod wcomponent-template ((cinput cinput)) (let ((client-id (htcomponent-client-id cinput)) (type (input-type cinput)) (translator (translator cinput)) @@ -243,20 +279,53 @@ (wcomponent-informal-parameters cinput)))) (defmethod wcomponent-after-rewind ((cinput base-cinput) (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))) + (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))) (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)))))) + (funcall (fdefinition writer) value visit-object))))))) -(defmethod component-id-and-value ((cinput base-cinput) &key (from-request-p t)) +(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)) @@ -264,30 +333,47 @@ (result-as-list-p (cinput-result-as-list-p cinput)) (value "")) (setf value - (cond - (from-request-p (page-req-parameter (htcomponent-page cinput) + (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))) + (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) +(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 + (: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." + "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) @@ -306,13 +392,15 @@ (wcomponent-informal-parameters obj)))) (defmethod wcomponent-after-rewind ((obj csubmit) (pobj page)) - (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)))) + (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) +(defclass submit-link (csubmit) () (:metaclass metacomponent) (:default-initargs :reserved-parameters (list :href) :empty nil) @@ -323,7 +411,7 @@ (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." + "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) @@ -332,7 +420,7 @@ (defmethod wcomponent-template ((obj submit-link)) (let* ((id (htcomponent-client-id obj)) (submit-id (generate-id id))) - (list + (list (input> :static-id submit-id :style "display:none;" :type "submit" @@ -347,14 +435,14 @@ (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, + (: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." + "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) @@ -380,7 +468,7 @@ ((test :initarg :test :accessor ccheckbox-test) (value :initarg :value - :accessor ccheckbox-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")) @@ -389,18 +477,18 @@ (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\"." + "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)) +(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))) + (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) @@ -416,25 +504,26 @@ (wcomponent-informal-parameters cinput)))) (defmethod wcomponent-after-rewind ((cinput ccheckbox) (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 ""))) + (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) - (if (and (null writer) accessor) - (funcall (fdefinition `(setf ,accessor)) new-value visit-object) - (funcall (fdefinition writer) new-value visit-object)))))) + (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) @@ -447,7 +536,7 @@ (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\"." + "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)) @@ -459,34 +548,35 @@ (htcomponent-real-id ccheckbox)) (defmethod wcomponent-after-rewind ((cinput cradio) (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)))))) + (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)) +(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))) + (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) Modified: trunk/main/claw-core/src/lisplet.lisp ============================================================================== --- trunk/main/claw-core/src/lisplet.lisp (original) +++ trunk/main/claw-core/src/lisplet.lisp Sat Jun 14 01:16:01 2008 @@ -49,7 +49,7 @@ - :WELCOME-PAGE-P When true, the function will be a welcome page, making the lisplet to redirect direct access to its base path to the expressed location - :LOGIN-PAGE-P Marks the function as a login page")) -(defgeneric lisplet-register-page-location (lisplet page-class location &key welcome-page-p login-page-p encoding) +(defgeneric lisplet-register-page-location (lisplet page-class location &key welcome-page-p login-page-p external-format) (:documentation "Registers a page into a lisplet for dispatching. parameters: - LISPLET the lisplet that will dispatch the page @@ -58,16 +58,16 @@ keys: - :WELCOME-PAGE-P When true, the page will be a welcome page, making the lisplet to redirect direct access to its base path to the expressed location - :LOGIN-PAGE-P Marks the page as a login page -- :ENCODING The charset encoding used to render the resource")) +- :EXTERNAL-FORMAT The FLEXI-STREAMS:EXTERNAL-FORMAT used to render the resource")) -(defgeneric lisplet-register-resource-location (lisplet resource-path location &optional content-type encoding) +(defgeneric lisplet-register-resource-location (lisplet resource-path location &optional content-type external-format) (:documentation "Registers a resource (file or directory) into a lisplet for dispatching. parameters: - LISPLET the lisplet that will dispatch the page - RESOURCE-PATH pathname of a file or directory that is to be registered for dispatching - LOCATION The url location where the resource will be registered (relative to the lisplet base path) - CONTENT-TYPE Meaningful only when the resource-path points to a file, indicates the resource content type -- ENCODING The charset encoding used to render the resource")) +- :EXTERNAL-FORMAT The FLEXI-STREAMS:EXTERNAL-FORMAT used to render the resource")) (defgeneric lisplet-dispatch-method (lisplet) (:documentation "Performs authorizations checking then makes a call to LISPLET-DISPATCH-REQUEST @@ -78,7 +78,7 @@ - LISPLET the lisplet object")) (defgeneric lisplet-protect (lisplet location roles) - (:documentation "protects all the resources that start with the given LOCATION, making them available only if the + (:documentation "protects all the resources that start with the given LOCATION, making them available only if the user is logged and belongs at least to one of the given roles. parameters: - LISPLET the lisplet object. @@ -86,7 +86,7 @@ - ROLES a string list containing all the roles allowed to acces the given location.")) (defgeneric lisplet-check-authorization (lisplet &optional request) - (:documentation "Performs authentication and authorization checking. + (:documentation "Performs authentication and authorization checking. Sets the return code of each REPLY, to +HTTP-OK+, +HTTP-FORBIDDEN+ or +HTTP-AUTHORIZATION-REQUIRED+. If the lisplet authentication type is :BASIC and the user isn't logged in, asks for a basic login.")) @@ -98,7 +98,7 @@ (defgeneric build-lisplet-location (lisplet) (:documentation "Constructs a full path prepending the lisplet base path to the given location")) -(setf *http-error-handler* +(setf *http-error-handler* ;;overrides the default hunchentoot error handling #'(lambda (error-code) (let* ((error-handlers (if (current-lisplet) @@ -107,8 +107,8 @@ (handler (gethash error-code error-handlers))) (if handler (funcall handler) - (let ((error-page (make-instance 'error-page - :title (format nil "Server error: ~a" error-code) + (let ((error-page (make-instance 'error-page + :title (format nil "Server error: ~a" error-code) :error-code error-code))) (with-output-to-string (*standard-output*) (page-render error-page))))))) @@ -118,13 +118,13 @@ :documentation "common base path all resources registered into this lisplet") (welcome-page :initarg :welcome-page :accessor lisplet-welcome-page - :documentation "url location for the welcome page") + :documentation "url location for the welcome page") (login-page :initarg :login-page :accessor lisplet-login-page - :documentation "url location for the welcome page") - (encoding :initarg :encoding - :accessor lisplet-encoding - :documentation "The default charset external format for resources provided by this lisplet.") + :documentation "url location for the welcome page") + (external-format :initarg :external-format + :accessor lisplet-external-format + :documentation "The default charset external format for resources provided by this lisplet.") (realm :initarg :realm :reader lisplet-realm :documentation "realm for requests that pass through this lisplet and session opened into this lisplet") @@ -139,10 +139,10 @@ :documentation "A collection of cons where the car is the protected url location and the cdr is a string list of roles allowhed to access the relative location") (redirect-protected-resources-p :initarg :redirect-protected-resources-p :accessor lisplet-redirect-protected-resources-p - :documentation "When not null every request will be redirected in https mode. When running in mod-lisp mode, *apache-http-port* and *apache-https-port* values are used")) - (:default-initargs :welcome-page nil + :documentation "When not null every request will be redirected in https mode. When running in mod-lisp mode, *apache-http-port* and *apache-https-port* values are used")) + (:default-initargs :welcome-page nil :login-page nil - :encoding :utf-8 + :external-format nil :realm "claw" :redirect-protected-resources-p nil) (:documentation "A lisplet is a container for resources provided trhough the clawserver. @@ -150,11 +150,11 @@ (defmethod clawserver-register-lisplet ((clawserver clawserver) (lisplet lisplet)) (let ((dispatchers (clawserver-dispatchers clawserver)) - (location (lisplet-base-path lisplet))) + (location (lisplet-base-path lisplet))) (setf (clawserver-dispatchers clawserver) (sort-by-location (pushnew-location (cons location #'(lambda () - (progn + (progn (setf (current-realm *request*) (lisplet-realm lisplet) (current-lisplet) lisplet) (lisplet-dispatch-method lisplet)))) @@ -163,7 +163,7 @@ (defmethod clawserver-unregister-lisplet ((clawserver clawserver) (lisplet lisplet)) (let ((dispatchers (clawserver-dispatchers clawserver)) (location (lisplet-base-path lisplet))) - (remove-by-location location dispatchers))) + (remove-by-location location dispatchers))) (defmethod build-lisplet-location ((lisplet lisplet)) @@ -175,8 +175,8 @@ :form :basic)) -(defmethod lisplet-register-function-location ((lisplet lisplet) function location &key welcome-page-p login-page-p) - (let ((pages (lisplet-pages lisplet))) +(defmethod lisplet-register-function-location ((lisplet lisplet) function location &key welcome-page-p login-page-p) + (let ((pages (lisplet-pages lisplet))) (setf (lisplet-pages lisplet) (sort-by-location (pushnew-location (cons location function) pages))) (when welcome-page-p @@ -184,31 +184,34 @@ (when login-page-p (setf (lisplet-login-page lisplet) location)))) -(defmethod lisplet-register-page-location ((lisplet lisplet) page-class location &key welcome-page-p login-page-p encoding) - (let ((charset-encoding (or encoding (lisplet-encoding lisplet)))) - (lisplet-register-function-location lisplet +(defmethod lisplet-register-page-location ((lisplet lisplet) page-class location &key welcome-page-p login-page-p external-format) + (let ((charset-external-format (or external-format (lisplet-external-format lisplet)))) + (lisplet-register-function-location lisplet #'(lambda () (with-output-to-string (*standard-output*) - (page-render (make-instance page-class :lisplet lisplet :url location :encoding charset-encoding)))) + (page-render (make-instance page-class :lisplet lisplet :url location :external-format charset-external-format)))) location :welcome-page-p welcome-page-p :login-page-p login-page-p))) -(defmethod lisplet-register-resource-location ((lisplet lisplet) resource-path location &optional content-type (encoding :utf-8)) +(defmethod lisplet-register-resource-location ((lisplet lisplet) resource-path location &optional content-type external-format) (let ((pages (lisplet-pages lisplet)) - (external-format (flexi-streams:make-external-format (or encoding (lisplet-encoding lisplet)) :eol-style :lf))) + (charset-external-format (or external-format (lisplet-external-format lisplet)))) (setf (lisplet-pages lisplet) (sort-by-location (pushnew-location - (cons location - (if (directory-pathname-p resource-path) + (cons location + (if (directory-pathname-p resource-path) #'(lambda () - (let ((resource-full-path (merge-pathnames + (let ((resource-full-path (merge-pathnames (uri-to-pathname (subseq (script-name) (+ (length (clawserver-base-path (current-server))) (length (lisplet-base-path lisplet)) (length location) 1))) resource-path))) - (setf (reply-external-format) external-format) - (handle-static-file resource-full-path content-type))) + (unless (or (null charset-external-format) + (eq (flexi-streams:external-format-name (reply-external-format)) + (flexi-streams:external-format-name charset-external-format))) + (setf (reply-external-format) charset-external-format)) + (handle-static-file resource-full-path content-type))) #'(lambda () (handle-static-file resource-path content-type)))) pages))))) @@ -225,9 +228,9 @@ (uri (script-name)) (welcome-page (lisplet-welcome-page lisplet))) (lisplet-check-authorization lisplet) - (when (= (return-code) +http-ok+) - (if (and welcome-page (string= uri base-path)) - (page-render (lisplet-welcome-page lisplet)) + (when (= (return-code) +http-ok+) + (if (and welcome-page (string= uri base-path)) + (page-render (lisplet-welcome-page lisplet)) (lisplet-dispatch-request lisplet))))) (defmethod lisplet-protect ((lisplet lisplet) location roles) @@ -238,7 +241,7 @@ protected-resources))))) (defun redirect-to-https (server request &optional uri) - "Redirects a request sent through http using https" + "Redirects a request sent through http using https" (let ((path (or uri (request-uri request))) (port (server-port request)) (protocol :http)) @@ -258,9 +261,9 @@ (login-config (current-config)) (login-page-url (format nil "~a/~a" base-path (lisplet-login-page lisplet))) (server (current-server request)) - (auth-basicp (eq (lisplet-authentication-type lisplet) :basic))) + (auth-basicp (eq (lisplet-authentication-type lisplet) :basic))) (setf (return-code) +http-ok+) - (when login-config + (when login-config (when (and auth-basicp (null princp)) (configuration-login login-config)) (setf princp (current-principal)) @@ -268,17 +271,17 @@ for match = (format nil "~a/~a" base-path (car protected-resource)) for allowed-roles = (cdr protected-resource) do (when (or (starts-with-subseq match uri) (string= login-page-url uri)) - (cond + (cond ((and princp (not (user-in-role-p allowed-roles)) (not (string= login-page-url uri))) (setf (return-code) +http-forbidden+) (throw 'handler-done nil)) ((and (null princp) auth-basicp) - (setf (return-code) +http-authorization-required+ + (setf (return-code) +http-authorization-required+ (header-out "WWW-Authenticate") (format nil "Basic realm=\"~A\"" (hunchentoot::quote-string (current-realm)))) (throw 'handler-done nil)) ((and (null princp) (null auth-basicp) (not (string= login-page-url uri))) (redirect-to-https server request login-page-url) - (throw 'handler-done nil)) + (throw 'handler-done nil)) #-:hunchentoot-no-ssl ((not (find (server-port request) (list (clawserver-sslport server) *apache-https-port*))) (redirect-to-https server request) (throw 'handler-done nil)))))))) Modified: trunk/main/claw-core/src/misc.lisp ============================================================================== --- trunk/main/claw-core/src/misc.lisp (original) +++ trunk/main/claw-core/src/misc.lisp Sat Jun 14 01:16:01 2008 @@ -29,10 +29,12 @@ (in-package :claw) -(defvar *apache-http-port* 80 +(setf *hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) + +(defvar *apache-http-port* 80 "Default apache http port when claw is running in mod_lisp mode") (defvar *apache-https-port* 443 - "Default apache https port when claw is running in mod_lisp mode") + "Default apache https port when claw is running in mod_lisp mode") (defvar *claw-libraries-resources* () "Global variable to hold exposed web resources") @@ -43,27 +45,27 @@ (items "")) (cond ((= st-size 0) "[]") ((= st-size 1) (format nil "[~a]" (prin1-to-string (first strings)))) - (t (format nil (format nil "[~a~a]" + (t (format nil (format nil "[~a~a]" (prin1-to-string (first strings)) (progn (dolist (str (rest strings)) (setf items (format nil "~a,~a" items (prin1-to-string str)))) items))))))) - + (defun sort-by-location (location-list) "Sorts a list of location items by their first element (the location itself)." (sort location-list #'(lambda (item1 item2) (string-not-lessp (first item1) (first item2))))) (defun sort-protected-resources (protected-resources) - "Sorts a list of protected resources. A protected resource is a cons where the car is the url + "Sorts a list of protected resources. A protected resource is a cons where the car is the url of the resource and the cdr is a list of roles allowhed to access that resource." (sort protected-resources #'(lambda (item1 item2) (string-lessp (car item1) (car item2))))) (defun remove-by-location (location location-list) - "Removes an item from LOCATION-LIST checking its first element + "Removes an item from LOCATION-LIST checking its first element against the LOCATION parameter" (delete-if #'(lambda (item) (string= (first item) location)) location-list)) @@ -72,7 +74,7 @@ registered (its first element)." (let ((result (remove-by-location (first location-items) location-list))) (setf result (push location-items result)))) - + (defun claw-start-session () "Starts a session bound to the current lisplet base path" (start-session (format nil "~a/" (build-lisplet-location (current-lisplet))))) @@ -122,7 +124,7 @@ (setf (session-value 'principal session) principal)) (defun user-in-role-p (roles &optional (session *session*)) - "Detects if current principal belongs to any of the expressed roles" + "Detects if current principal belongs to any of the expressed roles" (let ((principal (current-principal session))) (when principal (loop for el in (principal-roles principal) thereis (member el roles))))) @@ -138,8 +140,8 @@ (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 + (loop for element in tree + do (cond ((consp element) (setf result (append (nreverse (flatten element result-list)) result))) (t (push element result)))) (nreverse result))) @@ -153,8 +155,8 @@ (defmacro with-message (key &optional (default "") locale) "Returns a lambda function that can localize a message by its key. -The first message dispatching is made by the lisplet, then, if the message is not already vlorized the -computation is left to the current rendering page, then to the current rendering web component. +The first message dispatching is made by the lisplet, then, if the message is not already vlorized the +computation is left to the current rendering page, then to the current rendering web component. If the message is null after these passages the default value is used." (let ((current-lisplet (gensym)) (current-page (gensym)) @@ -163,12 +165,12 @@ (key-val key) (locale-val (gensym)) (default-val default)) - `#'(lambda () + `#'(lambda () (let ((,current-lisplet (current-lisplet)) (,current-page (current-page)) (,current-component (current-component)) (,locale-val ,locale) - (,result)) + (,result)) (unless ,locale-val (setf ,locale-val (user-locale))) (when ,current-lisplet @@ -176,7 +178,7 @@ (when (and (null ,result) ,current-page) (setf ,result (message-dispatch ,current-page ,key-val ,locale-val))) (when (and (null ,result) ,current-component) - (setf ,result (message-dispatch ,current-component ,key-val ,locale-val))) + (setf ,result (message-dispatch ,current-component ,key-val ,locale-val))) (when (null ,result) (setf ,locale-val "") (when ,current-lisplet @@ -192,14 +194,14 @@ (defun do-message (key &optional (default "") locale) "This function calls the lambda function returned by the WITH-MESSAGE macro." (funcall (with-message key default locale))) - + (defun user-locale (&optional (request *request*) (session *session*)) "This function returns the user locale. If no locale was directly set, the browser default locale is used." (let ((locale (when session (session-value 'locale session)))) (unless locale - (setf locale (first (loop for str in (all-matches-as-strings - "[A-Z|a-z|_]+" + (setf locale (first (loop for str in (all-matches-as-strings + "[A-Z|a-z|_]+" (regex-replace-all "-" (regex-replace-all ";.*" (header-in "ACCEPT-LANGUAGE" request) "") "_")) collect (if (> (length str) 2) (string-upcase str :start 2) @@ -212,24 +214,24 @@ (unless session (setf session (claw-start-session))) (setf (session-value 'locale session) locale)) - -(defun validation-errors (&optional (request *request*)) + +(defun validation-errors (&optional (request *request*)) "Resurns possible validation errors occurred during form rewinding" (aux-request-value :validation-errors request)) -(defun (setf validation-errors) (value &optional (request *request*)) +(defun (setf validation-errors) (value &optional (request *request*)) "Sets possible validation errors occurred during form rewinding" (setf (aux-request-value :validation-errors request) value)) -(defun validation-compliances (&optional (request *request*)) +(defun validation-compliances (&optional (request *request*)) "Resurns the list of components that pass validation during form rewinding" (aux-request-value :validation-compliances request)) -(defun (setf validation-compliances) (value &optional (request *request*)) +(defun (setf validation-compliances) (value &optional (request *request*)) "Sets the list of components that pass validation during form rewinding" (setf (aux-request-value :validation-compliances request) value)) -(defun add-validation-compliance (id &optional (request *request*)) +(defun add-validation-compliance (id &optional (request *request*)) "Adds a component id to the list of components that pass validation during form rewinding" (setf (validation-compliances request) (nconc (validation-compliances request) (list id)))) @@ -252,7 +254,7 @@ (defmethod initialize-instance :after ((class metacomponent) &key) (let* ((name (class-name class)) (builder-function (format nil "~a>" name)) - (symbolf (find-symbol builder-function))) + (symbolf (find-symbol builder-function))) (unless symbolf (setf symbolf (intern builder-function))) (setf (fdefinition symbolf) #'(lambda(&rest rest) (build-component name rest))))) @@ -261,15 +263,15 @@ "Helper function that generates documentation for wcomponent init functions" (let* ((class-slots (closer-mop:class-direct-slots class))) (format nil "~{~%~a~}" - (remove-if #'null + (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 + (format nil + "- :~a ~a" + slot-initarg (documentation slot 't)))))))))) - + (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 ") @@ -284,41 +286,46 @@ "No") (if (find-first-classdefault-initarg-value initargs :empty) "No" - "Yes") + "Yes") (if reserved-parameters (format nil "~{:~a ~}" (eval reserved-parameters)) - "NONE")))) + "NONE")))) -(defun register-library-resource (location resource-path &optional content-type (encoding :utf-8)) +(defun register-library-resource (location resource-path &optional content-type external-format) "Adds a RESOURCE \(a file or directory) as a library exposed resource to the given relative LOCATION." (setf *claw-libraries-resources* (sort-by-location (pushnew-location - (cons location - (if (directory-pathname-p resource-path) + (cons location + (if (directory-pathname-p resource-path) #'(lambda () - (let ((resource-full-path (merge-pathnames + (let ((resource-full-path (merge-pathnames (uri-to-pathname (subseq (script-name) (+ (length (clawserver-base-path (current-server))) (length location)))) - resource-path)) - (charset-encoding (flexi-streams:make-external-format encoding :eol-style :lf))) - (setf (reply-external-format) charset-encoding) - (handle-static-file resource-full-path content-type))) - #'(lambda () (let ((charset-encoding (flexi-streams:make-external-format encoding :eol-style :lf))) - (setf (reply-external-format) charset-encoding) + resource-path))) + (unless (or (null external-format) + (eq (flexi-streams:external-format-name (reply-external-format)) + (flexi-streams:external-format-name external-format))) + (setf (reply-external-format) external-format)) + (handle-static-file resource-full-path content-type))) + #'(lambda () (progn + (unless (or (null external-format) + (eq (flexi-streams:external-format-name (reply-external-format)) + (flexi-streams:external-format-name external-format))) + (setf (reply-external-format) external-format)) (handle-static-file resource-path content-type))))) *claw-libraries-resources*)))) (defun uri-to-pathname (uri &optional (relative t)) "Convert an URI to a pathname" (let* ((splitted-uri (split-sequence #\/ uri)) - (directory-list (butlast splitted-uri)) + (directory-list (butlast splitted-uri)) (file (first (last splitted-uri))) (pos (position #\. file :from-end t)) (file-name-and-type (if (and pos (> pos 0) (string-not-equal (subseq file (1+ pos)) "")) (list (subseq file 0 pos)(subseq file (1+ pos))) (list file)))) - (make-pathname :directory (if relative + (make-pathname :directory (if relative (cons :relative directory-list) (cons :absolute directory-list)) :name (first file-name-and-type) Modified: trunk/main/claw-core/src/packages.lisp ============================================================================== --- trunk/main/claw-core/src/packages.lisp (original) +++ trunk/main/claw-core/src/packages.lisp Sat Jun 14 01:16:01 2008 @@ -26,7 +26,7 @@ ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - + (in-package :cl-user) (export 'HUNCHENTOOT::REQUEST-REALM 'HUNCHENTOOT) @@ -42,29 +42,28 @@ :*xhtml-1.0-strict* :*xhtml-1.0-transitional* :*xhtml-1.0-frameset* - :*default-encoding* - :*rewind-parameter* + :*rewind-parameter* :*clawserver-base-path* :*apache-http-port* :*apache-https-port* :*empty-tags* :tag-emptyp - :strings-to-jsarray + :strings-to-jsarray :empty-string-p :build-tagf - :page - :page-encoding + :page + :page-external-format :page-url :page-lisplet :page-current-form - :page-req-parameter + :page-req-parameter :page-script-files :page-stylesheet-files :page-class-initscripts :page-instance-initscripts - :page-current-component + :page-current-component :page-body-init-scripts - :htcomponent + :htcomponent :htcomponent-page :htcomponent-body :htcomponent-empty @@ -74,14 +73,14 @@ :htcomponent-stylesheet-files :htcomponent-class-initscripts :htcomponent-instance-initscript - :tag + :tag :tag-name :tag-attributes :htbody :htscript :htlink :hthead - :htstring + :htstring :$> :$raw> ;empty tags definition @@ -177,27 +176,33 @@ :u> :ul> :var> - ;; class modifiers + ;; class modifiers :page-content :generate-id :metacomponent :wcomponent :wcomponent-informal-parameters :wcomponent-allow-informal-parametersp - :wcomponent-template + :wcomponent-template :wcomponent-before-rewind :wcomponent-after-rewind :wcomponent-before-prerender :wcomponent-after-prerender :wcomponent-before-render - :wcomponent-after-render + :wcomponent-after-render :cform + :form-method :cform> :action :action-link - :action-link> + :action-link> :cinput :cinput> + :ctextarea + :ctextarea> + :cinput-file + :cinput-file> + :cinput-result-as-list-p :ccheckbox :ccheckbox> :cradio @@ -208,23 +213,23 @@ :csubmit> :csubmit-value :submit-link - :submit-link> + :submit-link> :input-type :ccheckbox-value :css-class :name-attr :lisplet - :lisplet-encoding + :lisplet-external-format :lisplet-pages :lisplet-register-page-location :lisplet-register-function-location :lisplet-register-resource-location - :lisplet-protect + :lisplet-protect :lisplet-authentication-type :claw-start-session :build-lisplet-location ;; clawserver - :clawserver + :clawserver :clawserver-base-path :clawserver-register-lisplet :clawserver-unregister-lisplet @@ -240,7 +245,7 @@ :clawserver-input-chunking-p :clawserver-read-timeout :clawserver-write-timeout - :clawserver-login-config + :clawserver-login-config #+(and :unix (not :win32)) :clawserver-setuid #+(and :unix (not :win32)) :clawserver-setgid #-:hunchentoot-no-ssl :clawserver-ssl-certificate-file @@ -252,7 +257,7 @@ :*id-and-static-id-description* :describe-component-behaviour :describe-html-attributes-from-class-slot-initargs - :clawserver-register-configuration + :clawserver-register-configuration :configuration :configuration-login :principal @@ -273,7 +278,7 @@ :message-dispatcher :message-dispatch :simple-message-dispatcher - :simple-message-dispatcher-add-message + :simple-message-dispatcher-add-message :with-message :do-message ;;validation @@ -282,16 +287,22 @@ :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-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* :*locales* :validate :validation-errors Modified: trunk/main/claw-core/src/server.lisp ============================================================================== --- trunk/main/claw-core/src/server.lisp (original) +++ trunk/main/claw-core/src/server.lisp Sat Jun 14 01:16:01 2008 @@ -63,9 +63,9 @@ (:documentation "When boud to apache with mod_lisp2 if not nil, uses apache logging. When server is started an error will be signaled.")) (defgeneric (setf clawserver-input-chunking-p) (input-chunking-p clawserver) - (:documentation "Sets input-chunking-p, when true the server will accept request -bodies without a Content-Length header if the client uses chunked transfer encoding. -If you want to use this feature behind mod_lisp, you should make sure that your combination of + (:documentation "Sets input-chunking-p, when true the server will accept request +bodies without a Content-Length header if the client uses chunked transfer encoding. +If you want to use this feature behind mod_lisp, you should make sure that your combination of Apache and mod_lisp can cope with that. When server is started an error will be signaled.")) (defgeneric (setf clawserver-read-timeout) (read-timeout clawserver) @@ -97,18 +97,17 @@ (:documentation "Authenticate a user creating a principal object that will be stored into the http session. If no session is present one will be created, if the authentication succeds the principal instance is returned")) -(defclass error-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")) - (:default-initargs :encoding :utf-8) - (:documentation "This is the page class used to render + (:documentation "This is the page class used to render the http error messages.")) -(defclass error-page-template (wcomponent) +(defclass error-page-template (wcomponent) ((title :initarg :title :reader title :documentation "The page title") @@ -126,7 +125,7 @@ span.blue { background-color: #525D76; color: white; - font-weight: bolder; + font-weight: bolder; margin-right: .25em; } p.h1, p.h2 { @@ -152,7 +151,7 @@ (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))) + (style (style error-page-template))) (html> (head> (title> title) @@ -177,12 +176,12 @@ (hr> :noshade "noshade")) (p> :class "h2" "claw server")))))) - -(defmethod page-content ((error-page error-page)) - (error-page-template> :title (page-title error-page) + +(defmethod page-content ((error-page error-page)) + (error-page-template> :title (page-title error-page) :error-code (page-error-code error-page) - (format nil "The requested resource (~a) is not available." (request-uri *request*)))) - + (format nil "The requested resource (~a) is not available." (request-uri *request*)))) + (defclass clawserver () ((base-path :initarg :base-path :accessor clawserver-base-path @@ -204,15 +203,15 @@ :documentation "Returns the name of the server that dispatches https requests.") (mod-lisp-p :initarg :mod-lisp-p :reader clawserver-mod-lisp-p - :documentation "Returns not nil when the server is bound to apache through mod_lisp") + :documentation "Returns not nil when the server is bound to apache through mod_lisp") (use-apache-log-p :initarg :use-apache-log-p :reader clawserver-use-apache-log-p :documentation "Returns not nil when the server uses apache logging") (input-chunking-p :initarg :input-chunking-p :reader clawserver-input-chunking-p - :documentation "When true the server will accept request -bodies without a Content-Length header if the client uses chunked transfer encoding. -If you want to use this feature behind mod_lisp, you should make sure that your combination of + :documentation "When true the server will accept request +bodies without a Content-Length header if the client uses chunked transfer encoding. +If you want to use this feature behind mod_lisp, you should make sure that your combination of Apache and mod_lisp can cope with that.") (read-timeout :initarg :read-timeout :reader clawserver-read-timeout @@ -249,23 +248,23 @@ (dispatchers :initform nil :accessor clawserver-dispatchers :documentation "A collection of cons where the car is an url location where a lisplet is registered and the cdr is a dispatcher for that lisplet")) - (:default-initargs :base-path "" + (:default-initargs :base-path "" :use-apache-log-p nil - :address nil + :address nil :name (gensym) :sslname (gensym) - :port 80 + :port 80 :sslport 443 - :mod-lisp-p nil + :mod-lisp-p nil :input-chunking-p t - :read-timeout *default-read-timeout* + :read-timeout *default-read-timeout* :write-timeout *default-write-timeout* #+(and :unix (not :win32)) :setuid nil #+(and :unix (not :win32)) :setgid nil #-:hunchentoot-no-ssl :ssl-certificate-file nil #-:hunchentoot-no-ssl :ssl-privatekey-password nil) - (:documentation "CLAWSERVER is built around huncentoot and has the -instructions for lisplet dispatching, so use this class to start and stop + (:documentation "CLAWSERVER is built around huncentoot and has the +instructions for lisplet dispatching, so use this class to start and stop 3hunchentoot server.")) (defclass configuration () @@ -291,7 +290,7 @@ (when (eq use-apache-log-p :undefined) (setf (clawserver-use-apache-log-p clawserver) (getf keys :mod-lisp-p))) #-:hunchentoot-no-ssl (when (eq ssl-privatekey-file :undefined) - (setf (clawserver-ssl-privatekey-file clawserver) (getf keys :ssl-certificate-file))))) + (setf (clawserver-ssl-privatekey-file clawserver) (getf keys :ssl-certificate-file))))) ;;;-------------------------- WRITERS ---------------------------------------- @@ -385,8 +384,8 @@ (setf (current-server) clawserver) (when (starts-with-subseq script-name base-path) (setf rel-script-name (subseq script-name (length base-path)) - rel-script-name-libs (subseq script-name (1+ (length base-path)))) - (or + rel-script-name-libs (subseq script-name (1+ (length base-path)))) + (or (loop for dispatcher in *claw-libraries-resources* for url = (car dispatcher) for action = (cdr dispatcher) @@ -395,11 +394,11 @@ for url = (car dispatcher) for action = (cdr dispatcher) do (when (starts-with-subseq rel-script-name url) (return (funcall action)))))))) - + (defmethod clawserver-dispatch-method ((clawserver clawserver)) - (let ((result (clawserver-dispatch-request clawserver))) + (let ((result (clawserver-dispatch-request clawserver))) (if (null result) - #'(lambda () (when (= (return-code) +http-ok+) + #'(lambda () (when (= (return-code) +http-ok+) (setf (return-code *reply*) +http-not-found+))) #'(lambda () result)))) @@ -407,7 +406,7 @@ (let ((port (clawserver-port clawserver)) (sslport (clawserver-sslport clawserver)) (address (clawserver-address clawserver)) - (dispatch-table (list #'(lambda (request) + (dispatch-table (list #'(lambda (request) (declare (ignorable request)) (clawserver-dispatch-method clawserver)))) (name (clawserver-name clawserver)) @@ -451,9 +450,9 @@ :ssl-certificate-file ssl-certificate-file :ssl-privatekey-file ssl-privatekey-file :ssl-privatekey-password ssl-privatekey-password)))))) - + (defmethod clawserver-stop ((clawserver clawserver)) - (progn + (progn (setf (clawserver-server clawserver) (stop-server (clawserver-server clawserver))) (when (clawserver-sslserver clawserver) (setf (clawserver-sslserver clawserver) (stop-server (clawserver-sslserver clawserver)))))) @@ -464,4 +463,4 @@ (realm (current-realm request)) (login-config (gethash realm (clawserver-login-config server)))) (configuration-login login-config request))) - + Modified: trunk/main/claw-core/src/tags.lisp ============================================================================== --- trunk/main/claw-core/src/tags.lisp (original) +++ trunk/main/claw-core/src/tags.lisp Sat Jun 14 01:16:01 2008 @@ -33,25 +33,33 @@ (:documentation "Returns the KEY translation by the given LOCALE")) (defgeneric page-req-parameter (page name &optional as-list) - (:documentation "This method returns a request parameter given by NAME searching first + (: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 +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 + (: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-content (page) +(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) +(defgeneric page-init (page) (:documentation "Internal method for page initialization. - PAGE is the page instance that must be given")) @@ -60,7 +68,7 @@ - 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 + (: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")) @@ -68,8 +76,8 @@ (: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. +(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) @@ -83,8 +91,8 @@ (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. +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 @@ -92,8 +100,8 @@ (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. +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 @@ -101,9 +109,9 @@ (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. +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")) + - 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 @@ -115,25 +123,25 @@ (: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. + (: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. + (: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. + (: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 + (: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")) @@ -147,7 +155,7 @@ on component end. - HTCOMPONENT is the htcomponent instance")) -(defgeneric tag-render-starttag (tag page) +(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")) @@ -166,7 +174,7 @@ (: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 + (: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")) @@ -208,25 +216,25 @@ (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\">" +(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\">" +(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\">" +(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\">" +(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\">" +(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\">" +(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" +(defvar *rewind-parameter* "rewindobject" "The request parameter for the object asking for a rewind action") (defvar *empty-tags* @@ -236,29 +244,29 @@ "List of html empty tags") (defun request-id-table-map () - "Holds an hash table of used components/tags id as keys and the number of their occurrences as values. -So if you have a :id \"compId\" given to a previous component, the second + "Holds an hash table of used components/tags id as keys and the number of their occurrences as values. +So if you have a :id \"compId\" given to a previous component, the second time this id will be used, it will be rendered as \"compId1\", the third time will be \"compId2\" and so on" - (when (boundp '*request*) + (when (boundp '*request*) (let ((id-table-map (aux-request-value :id-table-map))) (if (null id-table-map) - (progn + (progn (setf (aux-request-value :id-table-map) (make-hash-table :test 'equal))) id-table-map)))) - + (defun reset-request-id-table-map () "This function resets the ID-TABLE-MAP built during the request cycle to handle id uniqueness. See REQUEST-ID-TABLE-MAP for more info." - (when (boundp '*request*) + (when (boundp '*request*) (setf (aux-request-value :id-table-map) (make-hash-table :test 'equal)))) (defun parse-htcomponent-function (function-body) "This function parses attributes passed to a htcomponent creation function" (let ((attributes) (body)) - (loop for last-elem = nil then elem - for elem in function-body - do (if (and (null 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) @@ -269,7 +277,7 @@ (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." +When used with :STATIC-ID the generated id will be mantained as is, and rendered just like the :ID tag attribute." (let* ((id-ht (request-id-table-map)) (client-id-index (gethash id id-ht 0)) (result)) @@ -281,29 +289,35 @@ (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\" +- 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 (request-id-table-map)) - (id (getf (first fbody) :id)) - (static-id (getf (first fbody) :static-id)) + (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 (first fbody) :id) + (remf attributes :id) (setf id nil)) - (setf instance (make-instance parent + (when render-condition + (remf attributes :render-condition)) + (setf instance (make-instance parent :empty emptyp :real-id real-id :name (string-downcase tag-name) - :attributes (first fbody) + :render-condition render-condition + :attributes attributes :body (second fbody))) - (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)) + (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) @@ -313,7 +327,7 @@ (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" + (setf (documentation fsymbol 'function) (format nil "This function generates the ~a<~a> html tag" (if emptyp "empty " "") @@ -321,17 +335,17 @@ ;;;---------------------------------------------------------------- -(defclass message-dispatcher () +(defclass message-dispatcher () () (:documentation "This is and interface for message dispatchers")) -(defclass simple-message-dispatcher (message-dispatcher) +(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) +(defclass i18n-aware (message-dispatcher) ((message-dispatcher :initarg :message-dispatcher :accessor message-dispatcher :documentation "Reference to a MESSAGE-DISPATCHER instance")) @@ -340,12 +354,12 @@ (defclass page(i18n-aware) ((writer :initarg :writer - :accessor page-writer :documentation "The output stream for this page instance") + :accessor page-writer :documentation "The output stream for this page instance") (lisplet :initarg :lisplet :reader page-lisplet :documentation "The lisplet that owns this page instance") (can-print :initform nil :accessor page-can-print - :documentation "Controls the printing process when a json request is dispatched. + :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") @@ -354,18 +368,18 @@ (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") + :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 + (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 + (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.") @@ -375,17 +389,20 @@ :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.") (components-stack :initform nil :accessor page-components-stack - :documentation "A stack of components enetered into rendering process.") + :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") - (encoding :initarg :encoding - :accessor page-encoding - :documentation "The charset external format. When not provided the lisplet one is used") + :accessor page-mime-type + :documentation "Define the mime type of the page when rendered") + (external-format :initarg :external-format + :accessor page-external-format + :documentation "The charset external format. When not provided the lisplet one is used") + (injection-writing-p :initform nil + :accessor page-injection-writing-p + :documentation "Flag that becomes true when rendering page injections") (url :initarg :url :accessor page-url :documentation "The URL provided with this page instance")) (:default-initargs :writer t - :script-files nil + :script-files nil :json-component-count 0 :stylesheet-files nil :class-initscripts nil @@ -396,12 +413,13 @@ :doc-type *html-4.01-strict* :request-parameters nil :mime-type "text/html" + :external-format nil :url nil) (:documentation "A page object holds claw components to be rendered") ) - + (defclass htcomponent (i18n-aware) ((page :initarg :page - :reader htcomponent-page :documentation "The owner 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.") @@ -410,11 +428,14 @@ (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") + :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 @@ -423,13 +444,13 @@ :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 + (:default-initargs :page nil :body nil :json-render-on-validation-errors-p nil - :client-id nil :real-id nil - :attributes nil + :attributes nil :empty nil + :render-condition nil :script-files nil :stylesheet-files nil :class-initscripts nil @@ -471,19 +492,19 @@ (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" + "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" + "This function generates the <body> html tag" (build-tagf "body" 'htbody nil rest)) (defclass hthead (tag) () @@ -499,21 +520,21 @@ (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" + '("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" + "noframes" "noscript" "object" "ol" "optgroup" "option" - "p" "pre" - "q" + "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")) @@ -523,15 +544,16 @@ (member tag-name *empty-tags* :test #'string-equal)) ;;;--------------------METHODS implementation---------------------------------------------- -(defmethod (setf htcomponent-page) ((page page) (htcomponent htcomponent)) - (let ((id (getf (htcomponent-attributes htcomponent) :id)) - (static-id (getf (htcomponent-attributes htcomponent) :static-id)) - (client-id (htcomponent-client-id htcomponent))) - (setf (slot-value htcomponent 'page) page) - (unless client-id - (if static-id - (setf (htcomponent-client-id htcomponent) static-id) - (setf (htcomponent-client-id htcomponent) (generate-id id)))))) +(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 (and (boundp '*request*) (null (slot-value page 'request-parameters))) @@ -539,7 +561,7 @@ (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) + (append (gethash (string-upcase (car kv)) pparameters) (list (cdr kv))))) (setf (slot-value page 'request-parameters) pparameters)) (slot-value page 'request-parameters))) @@ -558,7 +580,7 @@ (writer (page-writer page))) (if (null jsonp) (apply #'format writer str rest) - (apply #'format writer (list + (apply #'format writer (list (regex-replace-all "\"" (regex-replace-all "\\\\\"" (regex-replace-all "\\n" @@ -574,16 +596,22 @@ (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) + (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-encoding page)) + (let* ((jsonp (page-json-id-list page)) + (encoding (flexi-streams:external-format-name (or (page-external-format page) (reply-external-format)))) (xml-p (page-xmloutput page)) (doc-type (page-doc-type page))) (when (null jsonp) @@ -595,26 +623,29 @@ (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))) + (if validation-errors + (let* ((errors (loop for (component-id messages) on validation-errors by #'cddr + collect (symbol-name component-id) + collect (push 'array messages))) (js-struct (ps:ps* `(create ,@errors)))) - (subseq js-struct 0 (1- (length js-struct)))) + (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)) + +(defmethod page-render ((page page)) (let ((body (page-content page)) - (jsonp (page-json-id-list page))) - (setf (reply-external-format) - (flexi-streams:make-external-format (page-encoding page) :eol-style :lf)) + (jsonp (page-json-id-list page)) + (external-format (page-external-format page))) + (unless (or (null external-format) + (eq (flexi-streams:external-format-name (reply-external-format)) + (flexi-streams:external-format-name external-format))) + (setf (reply-external-format) external-format)) (if (null body) - (format nil "null body for page ~a~%" (type-of page)) + (format nil "null body for page ~a~%" (type-of page)) (progn (setf (current-page) page) (page-init page) @@ -623,13 +654,15 @@ (page-init page) (htcomponent-prerender (page-content page) page) ;Here we need a fresh new body!!! (page-render-headings page) - (page-init 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) + (setf (page-can-print page) t + (page-injection-writing-p page) t) (dolist (injection (page-init-injections page)) (when injection (htcomponent-render injection page))) @@ -641,7 +674,8 @@ (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-format-raw page (page-json-suffix page))))))) (defmethod page-body-init-scripts ((page page)) (let ((js-body "")) @@ -656,26 +690,26 @@ (tabulator (page-tabulator page)) (indent-p (page-indent page))) (when (and (<= 0 tabulator) indent-p (null jsonp)) - (page-format-raw page "~a" + (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 "~%")))) + (page-format-raw page "~%")))) (defmethod page-init-injections ((page page)) (let ((tag-list) - (class-init-scripts "")) + (class-init-scripts "")) (dolist (script (reverse (page-class-initscripts page))) - (setf class-init-scripts (format nil "~a~%~a" + (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))) + (push current-js tag-list))) (dolist (js-file (page-script-files page)) (if (typep js-file 'htcomponent) (push js-file tag-list) @@ -701,24 +735,24 @@ (car (page-components-stack page))))) ;;;========= HTCOMPONENT ============================ (defmethod htcomponent-can-print ((htcomponent htcomponent)) - (let* ((id (htcomponent-client-id htcomponent)) - (page (htcomponent-page 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))) - #|json-render-on-validation-errors-p|# + #|json-render-on-validation-errors-p|# (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 (htcomponent-client-id htcomponent)) - (validation-errors (validation-errors))) - (when (and jsonp - (or (and (null validation-errors) + (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) @@ -730,10 +764,10 @@ (defmethod htcomponent-json-print-end-component ((htcomponent htcomponent)) (let* ((page (htcomponent-page htcomponent)) (jsonp (page-json-id-list page)) - (id (htcomponent-client-id htcomponent)) + (id (when (slot-boundp htcomponent 'client-id) (htcomponent-client-id htcomponent))) (validation-errors (validation-errors))) - (when (and jsonp - (or (and (null 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)) @@ -744,21 +778,29 @@ (push htcomponent (page-components-stack page))) (defmethod htcomponent-prerender :before ((htcomponent htcomponent) (page page)) - (setf (htcomponent-page htcomponent) page) - (push htcomponent (page-components-stack 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)) - (setf (htcomponent-page htcomponent) page) - (push htcomponent (page-components-stack 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)) - (pop (page-components-stack 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)) - (pop (page-components-stack 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)) @@ -766,30 +808,34 @@ (htcomponent-rewind tag page)))) (defmethod htcomponent-prerender ((htcomponent htcomponent) (page page)) - (let ((previous-print-status (page-can-print page))) - (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)))) + (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)) +(defmethod htcomponent-render ((htcomponent htcomponent) (page page)) (let ((body-list (htcomponent-body htcomponent)) - (previous-print-status (page-can-print page))) - (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)))) + (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)) @@ -797,32 +843,40 @@ (defmethod tag-render-attributes ((tag tag) (page page)) (when (htcomponent-attributes tag) - (loop for (k v) on (htcomponent-attributes tag) by #'cddr + (loop for (k v) on (htcomponent-attributes tag) by #'cddr do (progn - (assert (keywordp k)) - (when (functionp v) + (assert (keywordp k)) + (when (and (functionp v) (not (eq k :render-condition))) (setf v (funcall v))) - (when (and v (string-not-equal v "")) - (page-format page " ~a=\"~a\"" - (string-downcase (if (eq k :static-id) - "id" - (parenscript::symbol-to-js k))) + (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)) - (prin1-to-string v)))) ;escapes double quotes + (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 (htcomponent-client-id 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))) + (xml-p (page-xmloutput page)) + (injection-writing-p (page-injection-writing-p page))) (setf (page-lasttag page) tagname) - (unless (and jsonp (string= id (first (page-json-component-id-list page)))) + (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) + (page-print-tabulation page) + (page-format page "<~a" tagname) (tag-render-attributes tag page) (if (null emptyp) (progn @@ -831,68 +885,77 @@ (if (null xml-p) (page-format page ">") (page-format page "/>")))))) - + (defmethod tag-render-endtag ((tag tag) (page page)) (let ((tagname (tag-name tag)) - (id (htcomponent-client-id 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))) - (when (and (null emptyp) (not (and jsonp - (string= id (first (page-json-component-id-list page)))))) - (progn + (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 + (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)) +(defmethod htcomponent-render ((tag tag) (page page)) (let ((body-list (htcomponent-body tag)) - (previous-print-status (page-can-print page))) - (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)) - (when (null (page-json-id-list page)) - (let ((body-list (htcomponent-body hthead)) - (injections (page-init-injections page))) - (tag-render-starttag hthead page) - (htcomponent-render (meta> :http-equiv "Content-Type" - :content (format nil "~a;charset=~a" - (page-mime-type page) - (page-encoding page))) - page) - (dolist (child-tag body-list) + (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 + (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)))) - + (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 (flexi-streams:external-format-name (or (page-external-format page) (reply-external-format))))) + (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))) @@ -901,26 +964,28 @@ (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))) - (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)))))))) + (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))) @@ -928,76 +993,82 @@ (defmethod htcomponent-render ((htscript htscript) (page page)) (let ((xml-p (page-xmloutput page)) (body (htcomponent-body htscript)) - (previous-print-status (page-can-print page))) - (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)))) + (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))) - (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)))) + (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))) - (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)))) - + (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-start-directive (if on-load (if (msie-p) @@ -1010,7 +1081,7 @@ "")) (page-body-init-scripts (page-body-init-scripts page))) (setf (htcomponent-page js) page - (htcomponent-body js) (when page-body-init-scripts + (htcomponent-body js) (when page-body-init-scripts (if (listp page-body-init-scripts) (append (list js-start-directive) page-body-init-scripts @@ -1022,18 +1093,18 @@ (defclass wcomponent (htcomponent) ((reserved-parameters :initarg :reserved-parameters :accessor wcomponent-reserved-parameters - :type cons + :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 + :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 + :allocation :class :documentation "Determines if the component accepts informal parameters")) (:default-initargs :reserved-parameters nil :allow-informal-parameters t) @@ -1061,17 +1132,17 @@ (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)) + (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) + 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 + (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" + (error (format nil + "Component ~a doesn't accept informal parameters" slot-initarg)) (setf (getf (wcomponent-informal-parameters wcomponent) initarg) new-value)))))) @@ -1085,7 +1156,7 @@ (real-id (or static-id id))) (setf (htcomponent-real-id instance) real-id) (when static-id - (remf parameters :id)) + (remf parameters :id)) (loop for (initarg value) on parameters by #'cddr do (setf (slot-initialization instance initarg) value)) (setf (htcomponent-body instance) content) @@ -1102,8 +1173,8 @@ (let ((template (wcomponent-template wcomponent))) (wcomponent-before-rewind wcomponent page) (if (listp template) - (dolist (tag template) - (htcomponent-rewind tag page)) + (dolist (tag template) + (htcomponent-rewind tag page)) (htcomponent-rewind template page)) (wcomponent-after-rewind wcomponent page))) @@ -1111,51 +1182,55 @@ (defmethod wcomponent-after-rewind ((wcomponent wcomponent) (page page))) (defmethod htcomponent-prerender ((wcomponent wcomponent) (page page)) - (wcomponent-before-prerender wcomponent page) - (let ((previous-print-status (page-can-print page)) - (template (wcomponent-template wcomponent))) - (when (null previous-print-status) - (setf (page-can-print page) (htcomponent-can-print wcomponent))) - (when (page-can-print page) - (dolist (script (htcomponent-script-files wcomponent)) - (pushnew script (page-script-files page) :test #'equal)) - (dolist (css (htcomponent-stylesheet-files wcomponent)) - (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)) + (let ((render-condition (htcomponent-render-condition wcomponent))) + (unless (and render-condition (null (funcall render-condition))) + (wcomponent-before-prerender wcomponent page) + (let ((previous-print-status (page-can-print page)) + (template (wcomponent-template wcomponent))) + (when (null previous-print-status) + (setf (page-can-print page) (htcomponent-can-print wcomponent))) + (when (page-can-print page) + (dolist (script (htcomponent-script-files wcomponent)) + (pushnew script (page-script-files page) :test #'equal)) + (dolist (css (htcomponent-stylesheet-files wcomponent)) + (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))) - (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)))) + (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))) @@ -1164,11 +1239,11 @@ (defmethod message-dispatch ((message-dispatcher message-dispatcher) key locale) nil) -(defmethod message-dispatch ((i18n-aware i18n-aware) key locale) +(defmethod message-dispatch ((i18n-aware i18n-aware) key locale) (let ((dispatcher (message-dispatcher i18n-aware)) (result)) (when dispatcher - (progn + (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)))))) @@ -1179,7 +1254,7 @@ (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) +(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)))) Modified: trunk/main/claw-core/src/translators.lisp ============================================================================== --- trunk/main/claw-core/src/translators.lisp (original) +++ trunk/main/claw-core/src/translators.lisp Sat Jun 14 01:16:01 2008 @@ -1,5 +1,5 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- -;;; $Header: src/components.lisp $ +;;; $Header: src/translators.lisp $ ;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. @@ -35,15 +35,15 @@ (defmethod translator-value-type-to-string ((translator translator) value) (translator-value-encode translator value)) -(defmethod translator-encode ((translator translator) (wcomponent cinput)) +(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))) + (reader (cinput-reader wcomponent)) + (value (page-req-parameter page (name-attr wcomponent) nil))) (if (component-validation-errors wcomponent) value - (progn + (progn (setf value (cond ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) (t (funcall (fdefinition reader) visit-object)))) @@ -52,14 +52,14 @@ (defmethod translator-type-to-string ((translator translator) (wcomponent cinput)) (translator-encode translator wcomponent)) -(defmethod translator-value-decode ((translator translator) value &optional client-id label) +(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) +(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)) +(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)))) @@ -67,13 +67,13 @@ (defmethod translator-string-to-type ((translator translator) (wcomponent wcomponent)) (translator-decode translator wcomponent)) -(setf *simple-translator* (make-instance 'translator)) +(setf *simple-translator* (make-instance 'translator)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;; Integer translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defclass 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 @@ -95,9 +95,9 @@ (signum-directive (if (translator-always-show-signum translator) "@" "")) - (control-string (if thousand-separator + (control-string (if thousand-separator (format nil "~~~d,',v:~aD" grouping-size signum-directive) - (format nil "~~~ad" signum-directive)))) + (format nil "~~~ad" signum-directive)))) (if thousand-separator (string-trim " " (format nil control-string thousand-separator value)) (format nil control-string value)))) @@ -108,28 +108,28 @@ (if thousand-separator (parse-integer (regex-replace-all (format nil "~a" thousand-separator) value "")) (parse-integer value)) - (error () (progn + (error () (progn (when label (add-exception client-id (format nil (do-message "VALIDATE-INTEGER" "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) +(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") + :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 #\. - ;:integer-digits nil - :decimal-digits nil + :decimal-digits nil :coerce 'ratio) (:documentation "a translator object encodes and decodes integer values passed to a html input component")) @@ -140,20 +140,20 @@ (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 + (integer-control-string (if thousand-separator (format nil "~~~d,',v:~aD" grouping-size signum-directive) - (format nil "~~~ad" 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" + (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 + (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 + (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)) @@ -163,8 +163,8 @@ (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)) + (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)) @@ -176,21 +176,23 @@ (if (integerp result) result (coerce result type))) - (error () (progn + (error () (progn (when label (add-exception client-id (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") label))) value))))) + +(defvar *number-translator* (make-instance 'translator-number)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;; Dates translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defclass translator-date (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 '(:month "/" :date "/" :year)) +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\". @@ -199,18 +201,18 @@ (defmethod translator-value-encode ((translator translator-date) value) - (let* ((local-time-format (translator-local-time-format translator))) + (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) +(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 0) - (month 0) + (day 1) + (month 1) (year 0) (old-value)) (when (and value (string-not-equal value "")) @@ -219,44 +221,51 @@ do (if (stringp element) (setf value (subseq value (length element))) (ccase element - (:second (multiple-value-bind (curr-value size) + (: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) + (: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) + (: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) + (: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) + (: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) + (: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) + (>= 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 + (progn (when label (add-exception client-id (format nil (do-message "VALIDATE-DATE" "Field ~a is not a valid date or wrong format: ~a") label old-value))) value))))) +(defvar *date-translator-ymd* (make-instance 'translator-date)) + +(defvar *date-translator-time* (make-instance 'translator-date :local-time-format '("T" :hour ":" :minute ":" :second))) -(defclass translator-boolean (translator) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;; Boolean translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass translator-boolean (translator) () (:documentation "a translator object encodes and decodes boolean values passed to a html input component")) @@ -268,4 +277,26 @@ nil t)) -(defvar *boolean-translator* (make-instance 'translator-boolean)) \ No newline at end of file +(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) + value) + +(setf *file-translator* (make-instance 'translator-file)) \ No newline at end of file Modified: trunk/main/claw-core/tests/test1.lisp ============================================================================== --- trunk/main/claw-core/tests/test1.lisp (original) +++ trunk/main/claw-core/tests/test1.lisp Sat Jun 14 01:16:01 2008 @@ -59,21 +59,21 @@ (simple-message-dispatcher-add-message *lisplet-messages* "it" "VALIDATE-REQUIRED" "Il campo ~a non può essere vuoto!") (defvar *test-lisplet*) -(setf *test-lisplet* (make-instance 'lisplet :realm "test1" :base-path "/test" +(setf *test-lisplet* (make-instance 'lisplet :realm "test1" :base-path "/test" :redirect-protected-resources-p t)) (defvar *test-lisplet2*) -(setf *test-lisplet2* (make-instance 'lisplet :realm "test2" +(setf *test-lisplet2* (make-instance 'lisplet :realm "test2" :base-path "/test2")) ;;(defparameter *clawserver* (make-instance 'clawserver :port 4242 :base-path "/claw")) -(defvar *clawserver* (make-instance 'clawserver - :port 4242 - :sslport 4445 +(defvar *clawserver* (make-instance 'clawserver + :port 4242 + :sslport 4445 :base-path "/claw" :mod-lisp-p nil - :ssl-certificate-file #P"/home/kiuma/pem/cacert.pem" + :ssl-certificate-file #P"/home/kiuma/pem/cacert.pem" :ssl-privatekey-file #P"/home/kiuma/pem/privkey.pem")) ;(setf (lisplet-redirect-protected-resources-p *test-lisplet*) t) @@ -85,24 +85,24 @@ (declare (ignore request)) (let ((session *session*)) (when (and (string-equal user "kiuma") - (string-equal password "password")) + (string-equal password "password")) (setf (current-principal session) (make-instance 'principal :name user :roles '("user")))))) - + (defclass test-configuration (configuration) ()) (defmethod configuration-login ((test-configuration test-configuration) &optional (request *request*)) - (let ((lisplet (current-lisplet request))) + (let ((lisplet (current-lisplet request))) (multiple-value-bind (user password) - (if (eq (lisplet-authentication-type lisplet) :basic) + (if (eq (lisplet-authentication-type lisplet) :basic) (authorization) (values (aux-request-value 'user request) (aux-request-value 'password request))) (test-configuration-do-login request user password)))) (clawserver-register-configuration *clawserver* "test1" (make-instance 'test-configuration)) - + (defun claw-tst-start () @@ -114,22 +114,22 @@ ;;;--------------------template-------------------------------- -(defclass site-template (wcomponent) +(defclass site-template (wcomponent) ((title :initarg :title :reader title)) (:metaclass metacomponent)) (defmethod wcomponent-template ((o site-template)) - (html> + (html> (head> - (title> + (title> (title o)) (style> :type "text/css" "input.error, div.error { background-color: #FF9999; } ")) - (body> + (body> (wcomponent-informal-parameters o) (div> :style "background-color: #DBDFE0;padding: 3px;" @@ -149,7 +149,7 @@ (defclass index-page (page) ()) -(defmethod page-content ((o index-page)) +(defmethod page-content ((o index-page)) (let ((clawserver-base-path (clawserver-base-path (current-server)))) (site-template> :title "Home test page" (p> :id "p" @@ -166,9 +166,9 @@ "show static file")) (li> (a> :href "images/matrix2.jpg" "show file by function")) - (li> (a> :href "../test/realm.html" :target "clwo1" + (li> (a> :href "../test/realm.html" :target "clwo1" "realm on lisplet 'test'")) - (li> (a> :href "../test2/realm.html" :target "clwo2" + (li> (a> :href "../test2/realm.html" :target "clwo2" "realm on lisplet 'test2'")) (li> (a> :href "id-tests.html" "id generation test")) (li> (a> :href "form.html" "form components test")) @@ -177,7 +177,7 @@ (lisplet-register-page-location *test-lisplet* 'index-page "index.html" :welcome-page-p t) -(defclass msie-p (wcomponent) +(defclass msie-p (wcomponent) () (:metaclass metacomponent)) @@ -186,7 +186,7 @@ (p> :static-id id))) (defmethod htcomponent-instance-initscript ((msie-p msie-p)) - (let ((id (htcomponent-client-id msie-p))) + (let ((id (htcomponent-client-id msie-p))) (format nil "document.getElementById('~a').innerHTML = '~a';" id (if (msie-p) @@ -195,14 +195,14 @@ (defclass info-page (page) ()) -(defmethod page-content ((o info-page)) +(defmethod page-content ((o info-page)) (let ((header-props (headers-in))) (site-template> :title "Header info page" (p> :id "p" (table> (tr> (td> :colspan "2" "Header info")) - (loop for key-val in header-props - collect (tr> + (loop for key-val in header-props + collect (tr> (td> (format nil "~a" (car key-val)) (td> (format nil "~a" (cdr key-val)))))))) (msie-p> :id "msie")))) @@ -210,12 +210,12 @@ (lisplet-register-page-location *test-lisplet* 'info-page "info.html") -(defun test-image-file () +(defun test-image-file () (make-pathname :directory (append (pathname-directory *this-file*) '("img")) :name "matrix" :type "jpg")) (lisplet-register-resource-location *test-lisplet* (test-image-file) "images/matrix.jpg" "image/jpeg") -(lisplet-register-function-location *test-lisplet* +(lisplet-register-function-location *test-lisplet* (lambda () (let ((path (test-image-file))) (setf (hunchentoot:content-type) (hunchentoot:mime-type path)) @@ -228,20 +228,20 @@ ;;;--------------------realm test page-------------------------------- (defclass realm-page (page) ()) -(defmethod page-content ((o realm-page)) - (when (null hunchentoot:*session*) +(defmethod page-content ((o realm-page)) + (when (null hunchentoot:*session*) (claw-start-session)) (unless (session-value 'RND-NUMBER) (setf (session-value 'RND-NUMBER) (random 1000))) - (site-template> :title "Realm test page" + (site-template> :title "Realm test page" (p> - "session" + "session" (ul> - (li> (a> :href "http://www.gentoo.org" :target "gentoo" + (li> (a> :href "http://www.gentoo.org" :target "gentoo" "gentoo")) - (li> (a> :href "../test/realm.html" :target "clwo1" + (li> (a> :href "../test/realm.html" :target "clwo1" "realm on lisplet 'test'")) - (li> (a> :href "../test2/realm.html" :target "clwo2" + (li> (a> :href "../test2/realm.html" :target "clwo2" "realm on lisplet 'test2'")) (li> "Rnd number value: " (format nil "~d" (session-value 'RND-NUMBER))) (li> "Remote Addr: " (session-remote-addr *session*)) @@ -260,22 +260,22 @@ (defmethod page-content ((o id-tests-page)) (let ((uid (generate-id "uid")) (uid2 (generate-id "uid"))) - (site-template> :title "a page title" + (site-template> :title "a page title" "\"<escaping>test\"" (hr>) - (div> :id "foo" :class "goo" + (div> :id "foo" :class "goo" :onclick "this.innerHTML = this.id" :style "cursor: pointer;" "passed id: 'foo'[click me, to see generated id]") - (div> :id "foo" + (div> :id "foo" :onclick "this.innerHTML = this.id" :style "cursor: pointer;" "passed id: 'foo'[click me, to see generated id]") - (div> :static-id uid + (div> :static-id uid :onclick "this.innerHTML = this.id" :style "cursor: pointer;" "passed id: 'uid' (generated with generate-id)[click me, to see generated id]") - (div> :static-id uid2 + (div> :static-id uid2 :onclick "this.innerHTML = this.id" :style "cursor: pointer;" "passed id: 'uid' (generated with generate-id)[click me, to see generated id]")))) @@ -287,7 +287,7 @@ (defgeneric login-page-login (login-page)) -(defclass login-page (page) +(defclass login-page (page) ((username :initform "" :accessor login-page-username) (passowrd :initform "" @@ -296,7 +296,7 @@ (defmethod page-content ((login-page login-page)) (let ((princp (current-principal))) - (site-template> :title "a page title" + (site-template> :title "a page title" (if (null princp) (cform> :id "loginform" :method "post" :action #'login-page-login (table> @@ -304,19 +304,21 @@ (td> "Username") (td> (cinput> :id "username" - :type "text" - :accessor 'login-page-username))) + :type "text" + :accessor 'login-page-username) + "\(kiuma)")) (tr> (td> "Password") (td> (cinput> :id "passowrd" :type "password" - :accessor 'login-page-password))) + :accessor 'login-page-password) + "\(password)")) (tr> (td> :colspan "2" (csubmit> :id "submit" :value "Login"))))) - (p> - (with-message "WELCOME" "WELCOME") " " + (p> + (with-message "WELCOME" "WELCOME") " " (principal-name princp) (a> :href "index.html" "home")))))) @@ -327,12 +329,12 @@ (lisplet-register-page-location *test-lisplet* 'login-page "login.html" :login-page-p t) -(defclass user () +(defclass user () ((name :initarg :name :accessor user-name) (surname :initarg :surname :accessor user-surname) - (gender :initarg :gender + (gender :initarg :gender :accessor user-gender) (age :initarg :age :accessor user-age) @@ -341,12 +343,12 @@ (sure :initarg :sure :accessor user-sure) (capital :initarg :capital - :accessor user-capital)) + :accessor user-capital)) (:default-initargs :name "" :surname "" :gender "" :age "" :capital 0.0 :sure "" :agree "")) (defgeneric form-page-update-user (form-page)) -(defclass form-page (page user) +(defclass form-page (page user) ((name :initarg :name :accessor form-page-name) (surname :initarg :surname @@ -367,7 +369,7 @@ (capital :initarg :capital :accessor form-page-capital) (birthday :initarg :birthday - :accessor form-page-birthday)) + :accessor form-page-birthday)) (:default-initargs :name "kiuma" :surname "surnk" :colors nil @@ -396,16 +398,16 @@ (user-sure user) sure))) - + (defun validate-agree (component value) (declare (ignore value)) (validate nil - :component component + :component component :message (do-message "SURE-ERROR-MESSAGE" "You must be sure"))) -(defmethod page-content ((o form-page)) +(defmethod page-content ((o form-page)) (let ((user (form-page-user o))) - (site-template> :title "a page title" + (site-template> :title "a page title" (cform> :id "testform" :method "post" :action #'form-page-update-user (table> (tr> @@ -414,7 +416,7 @@ (cinput> :id "name" :type "text" :label "Name" - :validator #'(lambda (value) + :validator #'(lambda (value) (validate-required (page-current-component o) value)) :accessor 'form-page-name)"*")) (tr> :id "messaged" @@ -423,7 +425,7 @@ (cinput> :id "surname" :type "text" :label "Surname" - :validator #'(lambda (value) + :validator #'(lambda (value) (validate-required (page-current-component o) value) (validate-size (page-current-component o) value :min-size 1 :max-size 20)) :accessor 'form-page-surname)"*")) @@ -432,29 +434,29 @@ (td> (ccheckbox> :id "agree" :label (with-message "AGREE" "AGREE") - :validator #'(lambda (value) + :validator #'(lambda (value) (validate-required (page-current-component o) value)) :accessor 'form-page-agree :value t)"*")) (tr> :id "sure" (td> (with-message "SURE" "SURE")) (td> - (cradio> :id "sure" + (cradio> :id "sure" :label (with-message "SURE" "SURE") :accessor 'form-page-sure - :value "yes") + :value "yes") (span> :style "margin-right:1.5em;" (with-message "YES" "yes")) - (cradio> :id "sure" + (cradio> :id "sure" :label (with-message "SURE" "SURE") - :validator #'(lambda (value) + :validator #'(lambda (value) (validate-agree (page-current-component o) value)) :accessor 'form-page-sure - :value "no") + :value "no") (span> :style "margin-right:1.5em;" (with-message "NO" "no")))) (tr> (td> "Gender") (td> - (cselect> :id "gender" + (cselect> :id "gender" :accessor 'form-page-gender (loop for gender in (list "M" "F") collect (option> :value gender @@ -470,7 +472,7 @@ :type "text" :label "Age" :translator (make-instance 'translator-integer :thousand-separator #\') - :validator #'(lambda (value) + :validator #'(lambda (value) (let ((component (page-current-component o))) (validate-required component value) (validate-integer component value :min 1 :max 2000))) @@ -482,7 +484,7 @@ :type "text" :label "Birthday" :translator (make-instance 'translator-date :local-time-format '(:date "-" :month "-" :year)) - :validator #'(lambda (value) + :validator #'(lambda (value) (let ((component (page-current-component o))) (validate-date-range component value :min (local-time:encode-local-time 0 0 0 0 31 12 1900)))) :accessor 'form-page-birthday)"(dd-mm-yyyy)")) @@ -492,10 +494,10 @@ (cinput> :id "capital" :type "text" :label "Capital" - :translator (make-instance 'translator-number + :translator (make-instance 'translator-number :decimal-digits 2 :thousand-separator #\') - :validator #'(lambda (value) + :validator #'(lambda (value) (let ((component (page-current-component o))) (validate-required component value) (validate-number component value :min 1000.01 :max 500099/100))) @@ -503,7 +505,7 @@ (tr> (td> "Colors") (td> - (cselect> :id "colors" + (cselect> :id "colors" :multiple "true" :style "width:80px;height:120px;" :accessor 'form-page-colors @@ -511,15 +513,15 @@ collect (option> :value color (when (find color (form-page-colors o) :test #'string=) '(:selected "selected")) - (cond + (cond ((string= color "R") "red") ((string= color "G") "green") - (t "blue"))))))) + (t "blue"))))))) (tr> (td> :colspan "2" (csubmit> :id "submit" :value "OK"))))) - (p> - (exception-monitor> :class "error") + (p> + (exception-monitor> :id "exceptionMonitor" :class "error") (hr>) (h2> "From result:") (div> (format nil "Name: ~a" (user-name user)))