Author: achiumenti Date: Fri May 30 06:03:00 2008 New Revision: 49 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/src/validators.lisp trunk/main/claw-core/tests/test1.lisp Log: a lot of bug fixes, plus adding of checkbox and radio components Modified: trunk/main/claw-core/src/components.lisp ============================================================================== --- trunk/main/claw-core/src/components.lisp (original) +++ trunk/main/claw-core/src/components.lisp Fri May 30 06:03:00 2008 @@ -41,9 +41,33 @@ (defgeneric translator-encode (translator wcomponent) (:documentation "Encodes the input component value, used when rendering the component (Encodes from type to string).")) +(defgeneric translator-type-to-string (translator wcomponent) + (:documentation "Encodes the input component value, used when rendering the component (Encodes from type to string). It's a wrapper for translator-encode")) + (defgeneric translator-decode (translator wcomponent) (:documentation "Decodes the input component value after a form submit (Decodes from string to type).")) +(defgeneric translator-string-to-type (translator wcomponent) + (:documentation "Decodes the input component value after a form submit (Decodes from string to type). It's a wrapper for translator-decode")) + +(defgeneric translator-value-encode (translator value) + (:documentation "Encodes the value, used when rendering the component (Encodes from type to string).")) + +(defgeneric translator-value-type-to-string (translator value) + (:documentation "Encodes the value, used when rendering the component (Encodes from type to string). It's a wrapper for translator-value-encode")) + +(defgeneric translator-value-decode (translator value &optional client-id label) + (:documentation "Decodes value after a form submit (Decodes from string to type).")) + +(defgeneric translator-value-string-to-type (translator value &optional client-id label) + (:documentation "Decodes value after a form submit (Decodes from string to type). It's a wrapper for translator-value-decode")) + +(defgeneric label (cinput) + (:documentation "Returns the label that describes the component. It's also be used when component validation fails. If it's a function it is funcalled")) + +(defgeneric name-attr (cinput) + (:documentation "Returns the name of the input component")) + (defclass translator () () (:documentation "a translator object encodes and decodes values passed to a html input component")) @@ -55,10 +79,12 @@ (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) (make-symbol client-id)))) + (getf (validation-errors request) (intern client-id)))) ;-------------------------------------------------------------------------------- + + (defclass cform (wcomponent) ((action :initarg :action :accessor action @@ -94,7 +120,6 @@ (setf class "error") (setf class (format nil "~a error" class)))) (form> :static-id client-id - :name client-id :class class (wcomponent-informal-parameters cform) (input> :name *rewind-parameter* @@ -154,8 +179,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 - :reader 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 @@ -173,6 +197,15 @@ :label nil :translator *simple-translator* :validator nil :visit-object nil) (:documentation "Class inherited from both CINPUT and CSELECT")) +(defmethod label ((cinput base-cinput)) + (let ((label (slot-value cinput 'label))) + (if (functionp label) + (funcall label) + label))) + +(defmethod name-attr ((cinput base-cinput)) + (htcomponent-client-id cinput)) + (defclass cinput (base-cinput) ((input-type :initarg :type :reader input-type @@ -204,7 +237,7 @@ (setf value (translator-encode translator cinput)) (input> :static-id client-id :type type - :name client-id + :name (name-attr cinput) :class class :value value (wcomponent-informal-parameters cinput)))) @@ -233,7 +266,7 @@ (setf value (cond (from-request-p (page-req-parameter (htcomponent-page cinput) - client-id + (name-attr cinput) result-as-list-p)) ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) (t (funcall (fdefinition reader) visit-object)))) @@ -260,12 +293,15 @@ (describe-html-attributes-from-class-slot-initargs class) (describe-component-behaviour class)))) +(defmethod name-attr ((csubmit csubmit)) + (htcomponent-client-id csubmit)) + (defmethod wcomponent-template ((obj csubmit)) (let ((client-id (htcomponent-client-id obj)) (value (csubmit-value obj))) (input> :static-id client-id :type "submit" - :name client-id + :name (name-attr obj) :value value (wcomponent-informal-parameters obj)))) @@ -300,7 +336,7 @@ (input> :static-id submit-id :style "display:none;" :type "submit" - :name id + :name (name-attr obj) :value "-") (a> :static-id id :href (format nil "javascript:document.getElementById('~a').click();" submit-id) @@ -332,12 +368,135 @@ (setf class "error") (setf class (format nil "~a error" class)))) (select> :static-id client-id - :name client-id + :name (name-attr obj) :class class :multiple (cinput-result-as-list-p obj) (wcomponent-informal-parameters obj) (htcomponent-body obj)))) +;-------------------------------------------------------------------------------------------- +(defclass ccheckbox (cinput) + ((test :initarg :test + :accessor ccheckbox-test) + (value :initarg :value + :accessor ccheckbox-value)) + (:metaclass metacomponent) + (:default-initargs :reserved-parameters (list :name) :empty t :type "checkbox" :test #'equal) + (:documentation "Request cycle aware component the renders as an INPUT tag class")) +(let ((class (find-class 'ccheckbox))) + (closer-mop:ensure-finalized class) + (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function) + (format nil "Description: ~a~%Parameters:~%~a~a~a~a~%~%~a" + "Function that instantiates a CCHECKBOX component and renders a html <input> tag of type \"checkbox\"." + *id-and-static-id-description* + (describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput)) + (describe-html-attributes-from-class-slot-initargs (find-class 'cinput)) + (describe-html-attributes-from-class-slot-initargs class) + (describe-component-behaviour class)))) +(defmethod wcomponent-template ((cinput ccheckbox)) + (let* ((client-id (htcomponent-client-id cinput)) + (translator (translator cinput)) + (type (input-type cinput)) + (value (translator-value-type-to-string translator (ccheckbox-value cinput))) + (current-value (translator-type-to-string translator cinput)) + (class (css-class cinput))) + (when (component-validation-errors cinput) + (if (or (null class) (string= class "")) + (setf class "error") + (setf class (format nil "~a error" class)))) + (input> :static-id client-id + :type type + :name (name-attr cinput) + :class class + :value value + :checked (when (and current-value (equal value current-value)) "checked") + (wcomponent-informal-parameters cinput)))) + +(defmethod wcomponent-after-rewind ((cinput ccheckbox) (page page)) + (let* ((visit-object (or (cinput-visit-object cinput) page)) + (client-id (htcomponent-client-id cinput)) + (translator (translator cinput)) + (accessor (cinput-accessor cinput)) + (writer (cinput-writer cinput)) + (validator (validator cinput)) + (result-as-list-p (cinput-result-as-list-p cinput)) + (new-value (page-req-parameter page + client-id + result-as-list-p))) + (when new-value + (setf new-value (translator-string-to-type translator cinput))) + (unless (component-validation-errors cinput) + (when validator + (funcall validator (or new-value ""))) + (unless (component-validation-errors cinput) + (if (and (null writer) accessor) + (funcall (fdefinition `(setf ,accessor)) new-value visit-object) + (funcall (fdefinition writer) new-value visit-object)))))) + +;------------------------------------------------------------------------------------- +(defclass cradio (ccheckbox) + () + (:metaclass metacomponent) + (:default-initargs :type "radio") + (:documentation "Request cycle aware component the renders as an INPUT tag class")) + +(let ((class (find-class 'cradio))) + (closer-mop:ensure-finalized class) + (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function) + (format nil "Description: ~a~%Parameters:~%~a~a~a~a~a~%~%~a" + "Function that instantiates a CRADIO component and renders a html <input> tag of type \"radio\"." + *id-and-static-id-description* + (describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput)) + (describe-html-attributes-from-class-slot-initargs (find-class 'cinput)) + (describe-html-attributes-from-class-slot-initargs (find-class 'ccheckbox)) + (describe-html-attributes-from-class-slot-initargs class) + (describe-component-behaviour class)))) + +(defmethod name-attr ((ccheckbox ccheckbox)) + (htcomponent-real-id ccheckbox)) + +(defmethod wcomponent-after-rewind ((cinput cradio) (page page)) + (let* ((visit-object (or (cinput-visit-object cinput) page)) + (translator (translator cinput)) + (accessor (cinput-accessor cinput)) + (writer (cinput-writer cinput)) + (validator (validator cinput)) + (ccheckbox-test (ccheckbox-test cinput)) + (result-as-list-p (cinput-result-as-list-p cinput)) + (value (translator-value-string-to-type translator (ccheckbox-value cinput))) + (new-value (page-req-parameter page + (name-attr cinput) + result-as-list-p)) + (checked)) + (when new-value + (setf new-value (translator-string-to-type translator cinput) + checked (funcall ccheckbox-test value new-value))) + (when (and checked (null (component-validation-errors cinput))) + (when validator + (funcall validator (or new-value ""))) + (when (null (component-validation-errors cinput)) + (if (and (null writer) accessor) + (funcall (fdefinition `(setf ,accessor)) new-value visit-object) + (funcall (fdefinition writer) new-value visit-object)))))) + +(defmethod wcomponent-template ((cinput cradio)) + (let* ((client-id (htcomponent-client-id cinput)) + (translator (translator cinput)) + (type (input-type cinput)) + (value (translator-value-type-to-string translator (ccheckbox-value cinput))) + (current-value (translator-type-to-string translator cinput)) + (class (css-class cinput))) + (when (component-validation-errors cinput) + (if (or (null class) (string= class "")) + (setf class "error") + (setf class (format nil "~a error" class)))) + (input> :static-id client-id + :type type + :name (name-attr cinput) + :class class + :value value + :checked (when (and current-value (equal value current-value)) "checked") + (wcomponent-informal-parameters cinput)))) Modified: trunk/main/claw-core/src/lisplet.lisp ============================================================================== --- trunk/main/claw-core/src/lisplet.lisp (original) +++ trunk/main/claw-core/src/lisplet.lisp Fri May 30 06:03:00 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) +(defgeneric lisplet-register-page-location (lisplet page-class location &key welcome-page-p login-page-p encoding) (:documentation "Registers a page into a lisplet for dispatching. parameters: - LISPLET the lisplet that will dispatch the page @@ -57,15 +57,17 @@ - LOCATION The url location where the page will be registered (relative to the lisplet base path) 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")) +- :LOGIN-PAGE-P Marks the page as a login page +- :ENCODING The charset encoding used to render the resource")) -(defgeneric lisplet-register-resource-location (lisplet resource-path location &optional content-type) +(defgeneric lisplet-register-resource-location (lisplet resource-path location &optional content-type encoding) (: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")) +- 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")) (defgeneric lisplet-dispatch-method (lisplet) (:documentation "Performs authorizations checking then makes a call to LISPLET-DISPATCH-REQUEST @@ -106,7 +108,7 @@ (if handler (funcall handler) (let ((error-page (make-instance 'error-page - :title (format nil "Server error: ~a" error-code) + :title (format nil "Server error: ~a" error-code) :error-code error-code))) (with-output-to-string (*standard-output*) (page-render error-page))))))) @@ -120,6 +122,9 @@ (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.") (realm :initarg :realm :reader lisplet-realm :documentation "realm for requests that pass through this lisplet and session opened into this lisplet") @@ -137,6 +142,7 @@ :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 :realm "claw" :redirect-protected-resources-p nil) (:documentation "A lisplet is a container for resources provided trhough the clawserver. @@ -170,7 +176,7 @@ :basic)) (defmethod lisplet-register-function-location ((lisplet lisplet) function location &key welcome-page-p login-page-p) - (let ((pages (lisplet-pages lisplet))) + (let ((pages (lisplet-pages lisplet))) (setf (lisplet-pages lisplet) (sort-by-location (pushnew-location (cons location function) pages))) (when welcome-page-p @@ -178,16 +184,18 @@ (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) - (lisplet-register-function-location lisplet - #'(lambda () (with-output-to-string (*standard-output*) - (page-render (make-instance page-class :lisplet lisplet :url location)))) - 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) - (let ((pages (lisplet-pages lisplet))) +(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 + #'(lambda () (with-output-to-string (*standard-output*) + (page-render (make-instance page-class :lisplet lisplet :url location :encoding charset-encoding)))) + 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)) + (let ((pages (lisplet-pages lisplet)) + (external-format (flexi-streams:make-external-format (or encoding (lisplet-encoding lisplet)) :eol-style :lf))) (setf (lisplet-pages lisplet) (sort-by-location (pushnew-location (cons location @@ -199,11 +207,7 @@ (length (lisplet-base-path lisplet)) (length location) 1))) resource-path))) - (log-message :info "--------------------------------------------- ~% -script-name: \"~a\"~% -resource-path: \"~a\"~% -resource-full-path :\"~a\"~% ---------------------------------------------" (script-name) resource-path resource-full-path) + (setf (reply-external-format) external-format) (handle-static-file resource-full-path content-type))) #'(lambda () (handle-static-file resource-path content-type)))) pages))))) @@ -214,9 +218,7 @@ (loop for dispatcher in dispatchers for url = (car dispatcher) for action = (cdr dispatcher) - do (progn - (log-message :info "rel-script-name: \"~a\" url: \"~a\" --- (starts-with-subseq rel-script-name url) : ~a" rel-script-name url (starts-with-subseq rel-script-name url)) - (when (starts-with-subseq rel-script-name url) (return (funcall action))))))) + do (when (starts-with-subseq rel-script-name url) (return (funcall action)))))) (defmethod lisplet-dispatch-method ((lisplet lisplet)) (let ((base-path (build-lisplet-location lisplet)) @@ -266,8 +268,6 @@ 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)) - ;(when (lisplet-redirect-protected-resources-p lisplet) - ;(redirect-to-https server request)) (cond ((and princp (not (user-in-role-p allowed-roles)) (not (string= login-page-url uri))) (setf (return-code) +http-forbidden+) Modified: trunk/main/claw-core/src/misc.lisp ============================================================================== --- trunk/main/claw-core/src/misc.lisp (original) +++ trunk/main/claw-core/src/misc.lisp Fri May 30 06:03:00 2008 @@ -289,7 +289,7 @@ (format nil "~{:~a ~}" (eval reserved-parameters)) "NONE")))) -(defun register-library-resource (location resource-path &optional content-type) +(defun register-library-resource (location resource-path &optional content-type (encoding :utf-8)) "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 @@ -300,9 +300,13 @@ (uri-to-pathname (subseq (script-name) (+ (length (clawserver-base-path (current-server))) (length location)))) - resource-path))) + 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 () (handle-static-file resource-path content-type)))) + #'(lambda () (let ((charset-encoding (flexi-streams:make-external-format encoding :eol-style :lf))) + (setf (reply-external-format) charset-encoding) + (handle-static-file resource-path content-type))))) *claw-libraries-resources*)))) (defun uri-to-pathname (uri &optional (relative t)) Modified: trunk/main/claw-core/src/packages.lisp ============================================================================== --- trunk/main/claw-core/src/packages.lisp (original) +++ trunk/main/claw-core/src/packages.lisp Fri May 30 06:03:00 2008 @@ -53,6 +53,7 @@ :empty-string-p :build-tagf :page + :page-encoding :page-url :page-lisplet :page-current-form @@ -68,6 +69,7 @@ :htcomponent-body :htcomponent-empty :htcomponent-client-id + :htcomponent-real-id :htcomponent-script-files :htcomponent-stylesheet-files :htcomponent-class-initscripts @@ -188,14 +190,18 @@ :wcomponent-before-prerender :wcomponent-after-prerender :wcomponent-before-render - :wcomponent-after-render + :wcomponent-after-render :cform :cform> :action :action-link - :action-link> + :action-link> :cinput :cinput> + :ccheckbox + :ccheckbox> + :cradio + :cradio> :cselect :cselect> :csubmit @@ -203,7 +209,12 @@ :csubmit-value :submit-link :submit-link> + :input-type + :ccheckbox-value + :css-class + :name-attr :lisplet + :lisplet-encoding :lisplet-pages :lisplet-register-page-location :lisplet-register-function-location @@ -269,10 +280,18 @@ :translator :translator-integer :translator-number + :translator-boolean :translator-date :translator-encode :translator-decode + :translator-string-to-type + :translator-type-to-string + :translator-value-decode + :translator-value-encode + :translator-value-string-to-type + :translator-value-type-to-string :*simple-translator* + :*boolean-translator* :*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 Fri May 30 06:03:00 2008 @@ -104,6 +104,7 @@ (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 the http error messages.")) Modified: trunk/main/claw-core/src/tags.lisp ============================================================================== --- trunk/main/claw-core/src/tags.lisp (original) +++ trunk/main/claw-core/src/tags.lisp Fri May 30 06:03:00 2008 @@ -226,9 +226,6 @@ (defvar *xhtml-1.0-frameset* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Frameset//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd\">" "Page doctype as XHTML 4.01 FRAMESET") -(defvar *default-encoding* "UTF-8" - "Page default encoding (if no changes 'UTF-8')") - (defvar *rewind-parameter* "rewindobject" "The request parameter for the object asking for a rewind action") @@ -292,19 +289,20 @@ (id-table-map (request-id-table-map)) (id (getf (first fbody) :id)) (static-id (getf (first fbody) :static-id)) + (real-id (or static-id id)) (instance)) (when static-id (remf (first fbody) :id) (setf id nil)) (setf instance (make-instance parent :empty emptyp + :real-id real-id :name (string-downcase tag-name) :attributes (first fbody) :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) (generate-id id))) (setf (htcomponent-client-id instance) static-id)) instance)) @@ -378,9 +376,12 @@ (components-stack :initform nil :accessor page-components-stack :documentation "A stack of components enetered into rendering process.") - (content-type :initarg :content-type - :accessor page-content-type - :documentation "Define the content type of the page when rendered") + (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") (url :initarg :url :accessor page-url :documentation "The URL provided with this page instance")) (:default-initargs :writer t @@ -394,7 +395,7 @@ :xmloutput nil :doc-type *html-4.01-strict* :request-parameters nil - :content-type hunchentoot:*default-content-type* + :mime-type "text/html" :url nil) (:documentation "A page object holds claw components to be rendered") ) @@ -408,6 +409,8 @@ :accessor htcomponent-body :documentation "The tag body") (client-id :initarg :client-id :accessor htcomponent-client-id :documentation "The tag computed id if :ID war provided for the building function") + (real-id :initarg :real-id + :accessor htcomponent-real-id :documentation "The tag real id got from :ID or :STATIC-ID") (attributes :initarg :attributes :accessor htcomponent-attributes :documentation "The tag attributes") (empty :initarg :empty @@ -424,6 +427,7 @@ :body nil :json-render-on-validation-errors-p nil :client-id nil + :real-id nil :attributes nil :empty nil :script-files nil @@ -578,17 +582,15 @@ (setf (page-tabulator page) 0))) (defmethod page-render-headings ((page page)) - (let* ((writer (page-writer page)) - (jsonp (page-json-id-list page)) - (encoding (handler-case (format nil "~a" (stream-external-format writer)) - (error () (format nil "~a" *default-encoding*)))) + (let* ((jsonp (page-json-id-list page)) + (encoding (page-encoding page)) (xml-p (page-xmloutput page)) - (content-type (page-doc-type page))) + (doc-type (page-doc-type page))) (when (null jsonp) (when xml-p - (page-format-raw page "<?xml version=\"1.0\" encoding=\"~a\"?>~%" encoding)) - (when content-type - (page-format-raw page "~a~%" content-type))))) + (page-format-raw page "<?xml version=\"1.0\" encoding=\"~a\"?>~%" encoding)) + (when doc-type + (page-format-raw page "~a~%" doc-type))))) (defun json-validation-errors () "Composes the error part for the json reply" @@ -609,7 +611,8 @@ (defmethod page-render ((page page)) (let ((body (page-content page)) (jsonp (page-json-id-list page))) - (setf (hunchentoot:content-type) (page-content-type page)) + (setf (reply-external-format) + (flexi-streams:make-external-format (page-encoding page) :eol-style :lf)) (if (null body) (format nil "null body for page ~a~%" (type-of page)) (progn @@ -874,7 +877,11 @@ (let ((body-list (htcomponent-body hthead)) (injections (page-init-injections page))) (tag-render-starttag hthead page) - (htcomponent-render (meta> :http-equiv "Content-Type" :content (page-content-type page)) 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) (when child-tag (cond @@ -1072,8 +1079,11 @@ (defun make-component (name parameters content) "This function instantiates a wcomponent by the passed NAME, separetes parameters into formal(the ones that are the initarg of a slot, and informal parameters, that have their own slot in common. The CONTENT is the body content." - (let ((instance (make-instance name)) - (static-id (getf parameters :static-id))) + (let* ((instance (make-instance name)) + (id (getf parameters :id)) + (static-id (getf parameters :static-id)) + (real-id (or static-id id))) + (setf (htcomponent-real-id instance) real-id) (when static-id (remf parameters :id)) (loop for (initarg value) on parameters by #'cddr Modified: trunk/main/claw-core/src/translators.lisp ============================================================================== --- trunk/main/claw-core/src/translators.lisp (original) +++ trunk/main/claw-core/src/translators.lisp Fri May 30 06:03:00 2008 @@ -29,28 +29,45 @@ (in-package :claw) +(defmethod translator-value-encode ((translator translator) value) + (format nil "~a" value)) + +(defmethod translator-value-type-to-string ((translator translator) value) + (translator-value-encode translator value)) + (defmethod translator-encode ((translator translator) (wcomponent cinput)) - (let ((page (htcomponent-page wcomponent)) - (visit-object (cinput-visit-object wcomponent)) - (accessor (cinput-accessor wcomponent)) - (reader (cinput-reader wcomponent))) - (format nil "~a" (if (component-validation-errors wcomponent) - (page-req-parameter page (htcomponent-client-id wcomponent) nil) - (progn - (when (null visit-object) - (setf visit-object (htcomponent-page wcomponent))) - (if (and (null reader) accessor) - (funcall (fdefinition accessor) visit-object) - (funcall (fdefinition reader) visit-object))))))) + (let* ((page (htcomponent-page wcomponent)) + (visit-object (or (cinput-visit-object wcomponent) page)) + (accessor (cinput-accessor wcomponent)) + (reader (cinput-reader wcomponent)) + (value (page-req-parameter page (name-attr wcomponent) nil))) + (if (component-validation-errors wcomponent) + value + (progn + (setf value (cond + ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) + (t (funcall (fdefinition reader) visit-object)))) + (translator-value-encode translator value))))) + +(defmethod translator-type-to-string ((translator translator) (wcomponent cinput)) + (translator-encode translator wcomponent)) + +(defmethod translator-value-decode ((translator translator) value &optional client-id label) + (declare (ignore client-id label)) + value) + +(defmethod translator-value-string-to-type ((translator translator) value &optional client-id label) + (translator-value-decode translator value client-id label)) (defmethod translator-decode ((translator translator) (wcomponent wcomponent)) - (multiple-value-bind (client-id new-value) + (multiple-value-bind (client-id value) (component-id-and-value wcomponent) - (declare (ignore client-id)) - new-value)) + (translator-value-decode translator value client-id (label wcomponent)))) -(setf *simple-translator* (make-instance 'translator)) +(defmethod translator-string-to-type ((translator translator) (wcomponent wcomponent)) + (translator-decode translator wcomponent)) +(setf *simple-translator* (make-instance 'translator)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;; Integer translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -58,56 +75,43 @@ (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 + :reader translator-thousand-separator + :documentation "If specified (as character), it is the thousands separator. Despite of its name, grouping is done following the TRANSLATOR-GROUPING-SIZE, so it's not a real 'tousands' separator") (always-show-signum :initarg :always-show-signum - :reader translator-always-show-signum - :documentation "When true the signum is used also for displaying positive numbers.") + :reader translator-always-show-signum + :documentation "When true the signum is used also for displaying positive numbers.") (grouping-size :initarg :grouping-size - :reader translator-grouping-size - :documentation "Used only if TRANSLATOR-THOUSAND-SEPARATOR is defined. Default to 3")) + :reader translator-grouping-size + :documentation "Used only if TRANSLATOR-THOUSAND-SEPARATOR is defined. Default to 3")) (:default-initargs :thousand-separator nil :grouping-size 3 :always-show-signum nil) (:documentation "A translator object encodes and decodes integer values passed to a html input component")) -(defmethod translator-encode ((translator translator-integer) (wcomponent cinput)) - (let* ((page (htcomponent-page wcomponent)) - (visit-object (or (cinput-visit-object wcomponent) page)) - (accessor (cinput-accessor wcomponent)) - (reader (cinput-reader wcomponent)) - (grouping-size (translator-grouping-size translator)) - (thousand-separator (translator-thousand-separator translator)) - (signum-directive (if (translator-always-show-signum translator) - "@" - "")) - (control-string (if thousand-separator - (format nil "~~~d,',v:~aD" grouping-size signum-directive) - (format nil "~~~ad" signum-directive))) - - (value (page-req-parameter page (htcomponent-client-id wcomponent) nil))) - (if (component-validation-errors wcomponent) - value - (progn - (setf value (cond - ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) - (t (funcall (fdefinition reader) visit-object)))) - (if thousand-separator - (string-trim " " (format nil control-string thousand-separator value)) - (format nil control-string value)))))) +(defmethod translator-value-encode ((translator translator-integer) value) + (let* ((grouping-size (translator-grouping-size translator)) + (thousand-separator (translator-thousand-separator translator)) + (signum-directive (if (translator-always-show-signum translator) + "@" + "")) + (control-string (if thousand-separator + (format nil "~~~d,',v:~aD" grouping-size signum-directive) + (format nil "~~~ad" signum-directive)))) + (if thousand-separator + (string-trim " " (format nil control-string thousand-separator value)) + (format nil control-string value)))) -(defmethod translator-decode ((translator translator-integer) (wcomponent wcomponent)) +(defmethod translator-value-decode ((translator translator-integer) value &optional client-id label) (let ((thousand-separator (translator-thousand-separator translator))) - (multiple-value-bind (client-id value) - (component-id-and-value wcomponent) - (handler-case - (if thousand-separator - (parse-integer (regex-replace-all (format nil "~a" thousand-separator) value "")) - (parse-integer value)) - (error () (progn - (add-exception client-id (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") (label wcomponent))) - value)))))) + (handler-case + (if thousand-separator + (parse-integer (regex-replace-all (format nil "~a" thousand-separator) value "")) + (parse-integer value)) + (error () (progn + (when label + (add-exception client-id (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") label))) + value))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;Folating point number translator ;;;;;;;;;;;;;;;; @@ -115,79 +119,67 @@ (defclass translator-number (translator-integer) ((decimals-separator :initarg :decimals-separator - :reader translator-decimals-separator - :documentation "The decimal separator of the rendered number. Default to #\.") + :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") + :reader translator-decimal-digits + :documentation "force the rendering of the value to a fixed number of decimal digits") (coerce :initarg :coerce - :accessor translator-coerce - :documentation "Coerces the decoded input value to the given value type")) + :accessor translator-coerce + :documentation "Coerces the decoded input value to the given value type")) (:default-initargs :decimals-separator #\. - ;:integer-digits nil - :decimal-digits nil - :coerce 'ratio) + ;:integer-digits nil + :decimal-digits nil + :coerce 'ratio) (:documentation "a translator object encodes and decodes integer values passed to a html input component")) -(defmethod translator-encode ((translator translator-number) (wcomponent cinput)) - (let* ((page (htcomponent-page wcomponent)) - (visit-object (or (cinput-visit-object wcomponent) page)) - (accessor (cinput-accessor wcomponent)) - (reader (cinput-reader wcomponent)) - (thousand-separator (translator-thousand-separator translator)) - (grouping-size (translator-grouping-size translator)) - (decimal-digits (translator-decimal-digits translator)) - (decimals-separator (translator-decimals-separator translator)) - (signum-directive (if (translator-always-show-signum translator) "@" "")) - (integer-control-string (if thousand-separator - (format nil "~~~d,',v:~aD" grouping-size signum-directive) - (format nil "~~~ad" signum-directive))) - (value (page-req-parameter page (htcomponent-client-id wcomponent) nil))) - (if (component-validation-errors wcomponent) - value - (multiple-value-bind (int-value dec-value) - (floor (cond - ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) - (t (funcall (fdefinition reader) visit-object)))) - (setf dec-value (coerce dec-value 'float)) - (format nil "~a~a" - (if thousand-separator - (string-trim " " (format nil integer-control-string thousand-separator int-value)) - (format nil integer-control-string int-value)) - (cond - ((and (= 0.0 (coerce dec-value 'double-float)) decimal-digits) - (format nil "~a~a" decimals-separator (make-string decimal-digits :initial-element #\0))) - (decimal-digits - (let ((frac-part (subseq (format nil "~f" dec-value) 2))) - (if (> (length frac-part) decimal-digits) - (setf frac-part (subseq frac-part 0 decimal-digits)) - (setf frac-part (concatenate 'string frac-part (make-string (- decimal-digits (length frac-part)) :initial-element #\0)))) - (format nil "~a~a" decimals-separator frac-part))) - (t (format nil "~a~a" decimals-separator (subseq (format nil "~f" dec-value) 2))))))))) - +(defmethod translator-value-encode ((translator translator-number) value) + (let* ((thousand-separator (translator-thousand-separator translator)) + (grouping-size (translator-grouping-size translator)) + (decimal-digits (translator-decimal-digits translator)) + (decimals-separator (translator-decimals-separator translator)) + (signum-directive (if (translator-always-show-signum translator) "@" "")) + (integer-control-string (if thousand-separator + (format nil "~~~d,',v:~aD" grouping-size signum-directive) + (format nil "~~~ad" signum-directive)))) + (multiple-value-bind (int-value dec-value) + (floor value) + (setf dec-value (coerce dec-value 'float)) + (format nil "~a~a" + (if thousand-separator + (string-trim " " (format nil integer-control-string thousand-separator int-value)) + (format nil integer-control-string int-value)) + (cond + ((and (= 0.0 (coerce dec-value 'double-float)) decimal-digits) + (format nil "~a~a" decimals-separator (make-string decimal-digits :initial-element #\0))) + (decimal-digits + (let ((frac-part (subseq (format nil "~f" dec-value) 2))) + (if (> (length frac-part) decimal-digits) + (setf frac-part (subseq frac-part 0 decimal-digits)) + (setf frac-part (concatenate 'string frac-part (make-string (- decimal-digits (length frac-part)) :initial-element #\0)))) + (format nil "~a~a" decimals-separator frac-part))) + (t (format nil "~a~a" decimals-separator (subseq (format nil "~f" dec-value) 2)))))))) -(defmethod translator-decode ((translator translator-number) (wcomponent wcomponent)) +(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)) - (multiple-value-bind (client-id value) - (component-id-and-value wcomponent) - (if thousand-separator - (setf new-value (regex-replace-all (format nil "~a" thousand-separator) value "")) - (setf new-value value)) - (handler-case - (let* ((decomposed-string (all-matches-as-strings "[0-9]+" new-value)) - (int-value (parse-integer (concatenate 'string (first decomposed-string) (second decomposed-string)))) - (dec-value (expt 10 (length (second decomposed-string)))) - (result (/ int-value dec-value))) - (if (integerp result) - result - (coerce result type))) - (error () (progn - (add-exception client-id (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") (label wcomponent))) - 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)) + (handler-case + (let* ((decomposed-string (all-matches-as-strings "[0-9]+" new-value)) + (int-value (parse-integer (concatenate 'string (first decomposed-string) (second decomposed-string)))) + (dec-value (expt 10 (length (second decomposed-string)))) + (result (/ int-value dec-value))) + (if (integerp result) + result + (coerce result type))) + (error () (progn + (when label + (add-exception client-id (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") label))) + value))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;; Dates translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -195,8 +187,8 @@ (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 + :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)) (:documentation "A translator object encodes and decodes local-date object value passed to a html input component. @@ -206,76 +198,74 @@ -(defmethod translator-encode ((translator translator-date) (wcomponent cinput)) - (let* ((page (htcomponent-page wcomponent)) - (visit-object (or (cinput-visit-object wcomponent) page)) - (accessor (cinput-accessor wcomponent)) - (reader (cinput-reader wcomponent)) - (local-time-format (translator-local-time-format translator)) - (value (page-req-parameter page (htcomponent-client-id wcomponent) nil))) - (if (component-validation-errors wcomponent) - value - (progn - (setf value (cond - ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) - (t (funcall (fdefinition reader) visit-object)))) - (if (and value (not (stringp value))) - (local-time-to-string value local-time-format) - value))))) +(defmethod translator-value-encode ((translator translator-date) value) + (let* ((local-time-format (translator-local-time-format translator))) + (if (and value (not (stringp value))) + (local-time-to-string value local-time-format) + value))) -(defmethod translator-decode ((translator translator-date) (wcomponent wcomponent)) +(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) - (year 0) - (old-value)) - (multiple-value-bind (client-id new-value) - (component-id-and-value wcomponent) - (declare (ignore client-id)) - (when (and new-value (string-not-equal new-value "")) - (setf old-value new-value) - (loop for element in date-format - do (if (stringp element) - (setf new-value (subseq new-value (length element))) - (ccase element - (:second (multiple-value-bind (value size) - (parse-integer new-value :junk-allowed t) - (setf new-value (subseq new-value size)) - (setf sec value))) - (:minute (multiple-value-bind (value size) - (parse-integer new-value :junk-allowed t) - (setf new-value (subseq new-value size)) - (setf min value))) - (:hour (multiple-value-bind (value size) - (parse-integer new-value :junk-allowed t) - (setf new-value (subseq new-value size)) - (setf hour value))) - (:date (multiple-value-bind (value size) - (parse-integer new-value :junk-allowed t) - (setf new-value (subseq new-value size)) - (setf day value))) - (:month (multiple-value-bind (value size) - (parse-integer new-value :junk-allowed t) - (setf new-value (subseq new-value size)) - (setf month value))) - (:year (multiple-value-bind (value size) - (parse-integer new-value :junk-allowed t) - (setf new-value (subseq new-value size)) - (setf year value)))))) - (validate (and (string-equal new-value "") - (>= sec 0) - (>= min 0) - (>= hour 0) - (and (> month 0) (<= month 12)) - (and (> day 0) (<= day (days-in-month month year)))) - :component wcomponent - :message (format nil (do-message "VALIDATE-DATE" "Field ~a is not a valid date or wrong format: ~a") - (label wcomponent) - old-value)) - (if (component-validation-errors wcomponent) - old-value - (encode-local-time 0 sec min hour day month year)))))) + (sec 0) + (min 0) + (hour 0) + (day 0) + (month 0) + (year 0) + (old-value)) + (when (and value (string-not-equal value "")) + (setf old-value value) + (loop for element in date-format + do (if (stringp element) + (setf value (subseq value (length element))) + (ccase element + (:second (multiple-value-bind (curr-value size) + (parse-integer value :junk-allowed t) + (setf value (subseq value size)) + (setf sec curr-value))) + (:minute (multiple-value-bind (curr-value size) + (parse-integer value :junk-allowed t) + (setf value (subseq value size)) + (setf min curr-value))) + (:hour (multiple-value-bind (curr-value size) + (parse-integer value :junk-allowed t) + (setf value (subseq value size)) + (setf hour curr-value))) + (:date (multiple-value-bind (curr-value size) + (parse-integer value :junk-allowed t) + (setf value (subseq value size)) + (setf day curr-value))) + (:month (multiple-value-bind (curr-value size) + (parse-integer value :junk-allowed t) + (setf value (subseq value size)) + (setf month curr-value))) + (:year (multiple-value-bind (curr-value size) + (parse-integer value :junk-allowed t) + (setf value (subseq value size)) + (setf year curr-value)))))) + (if (and (string-equal value "") + (>= sec 0) + (>= min 0) + (>= hour 0) + (and (> month 0) (<= month 12)) + (and (> day 0) (<= day (days-in-month month year)))) + (encode-local-time 0 sec min hour day month year) + (progn + (when label + (add-exception client-id (format nil (do-message "VALIDATE-DATE" "Field ~a is not a valid date or wrong format: ~a") label old-value))) + value))))) + + +(defclass translator-boolean (translator) + () + (:documentation "a translator object encodes and decodes boolean values passed to a html input component")) + +(defmethod translator-value-encode ((translator translator-boolean) value) + (format nil "~a" value)) + +(defmethod translator-value-decode ((translator translator-boolean) value &optional client-id label) + (if (string-equal value "NIL") + nil + t)) +(defvar *boolean-translator* (make-instance 'translator-boolean)) \ No newline at end of file Modified: trunk/main/claw-core/src/validators.lisp ============================================================================== --- trunk/main/claw-core/src/validators.lisp (original) +++ trunk/main/claw-core/src/validators.lisp Fri May 30 06:03:00 2008 @@ -53,14 +53,14 @@ (defun add-exception (id reason) "Adds an exception for the given input component identified by its ID with the message expressed by REASON" (let* ((validation-errors (validation-errors)) - (symbol-id (make-symbol id)) + (symbol-id (intern id)) (errors (getf validation-errors symbol-id))) (setf (getf validation-errors symbol-id) (nconc errors (list reason)) (validation-errors *request*) validation-errors))) (defun component-exceptions (id) "Returns a list of exception connectd to the given component" - (let ((symbol-id (make-symbol id))) + (let ((symbol-id (intern id))) (getf (validation-errors) symbol-id))) (defun validate (test &key component message) @@ -70,15 +70,15 @@ (add-validation-compliance client-id) (add-exception client-id message)))) -(defun validate-required (component value) +(defun validate-required (component value &key message) "Checks if the required input field VALUE is present. If not, a localizable message \"Field ~a may not be empty.\" is sent with key \"VALIDATE-REQUIRED\". The argument for the message will be the :label attribute of the COMPONENT." (when (stringp value) (validate (and value (string-not-equal value "")) :component component - :message (format nil (do-message "VALIDATE-REQUIRED" "Field ~a may not be empty.") (label component))))) + :message (or message (format nil (do-message "VALIDATE-REQUIRED" "Field ~a may not be empty.") (label component)))))) -(defun validate-size (component value &key min-size max-size) +(defun validate-size (component value &key min-size max-size message-low message-hi) "Checks if the input field VALUE legth is less then or greater then rispectively of the form keywords :MIN-SIZE and :MAX-SIZE. If less then :MIN-SIZE, a localizable message \"Size of ~a may not be less then ~a chars.\" is sent with key \"VALIDATE-SIZE-MIN\". The argument for the message will be the :label attribute of the COMPONENT and the :MIN-ZIZE value. @@ -92,17 +92,17 @@ (when min-size (validate (>= value-len min-size) :component component - :message (format nil (do-message "VALIDATE-SIZE-MIN" "Size of ~a may not be less then ~a chars." ) - (label component) - min-size))) + :message (or message-low (format nil (do-message "VALIDATE-SIZE-MIN" "Size of ~a may not be less then ~a chars." ) + (label component) + min-size)))) (when max-size (validate (<= value-len max-size) :component component - :message (format nil (do-message "VALIDATE-SIZE-MAX" "Size of ~a may not be more then ~a chars." ) + :message (or message-hi (format nil (do-message "VALIDATE-SIZE-MAX" "Size of ~a may not be more then ~a chars." ) (label component) - max-size))))))) + max-size)))))))) -(defun validate-range (component value &key min max) +(defun validate-range (component value &key min max message-low message-hi) "Checks if the numeric input field VALUE is less then or greater then rispectively of the form keywords :MIN and :MAX. If less then :MIN, a localizable message \"Field ~a is not less then or equal to ~d.\" is sent with key \"VALIDATE-RANGE-MIN\". The argument for the message will be the :label attribute of the COMPONENT and the :MIN value. @@ -112,21 +112,21 @@ (and (when min (validate (>= value min) :component component - :message (format nil (do-message "VALIDATE-RANGE-MIN" "Field ~a is not greater then or equal to ~d") - (label component) - (if (typep min 'ratio) - (coerce min 'float) - min)))) + :message (or message-low (format nil (do-message "VALIDATE-RANGE-MIN" "Field ~a is not greater then or equal to ~d") + (label component) + (if (typep min 'ratio) + (coerce min 'float) + min))))) (when max (validate (<= value max) :component component - :message (format nil (do-message "VALIDATE-RANGE-MAX" "Field ~a is not less then or equal to ~d") - (label component) - (if (typep max 'ratio) - (coerce max 'float) - max))))))) + :message (or message-hi (format nil (do-message "VALIDATE-RANGE-MAX" "Field ~a is not less then or equal to ~d") + (label component) + (if (typep max 'ratio) + (coerce max 'float) + max)))))))) -(defun validate-number (component value &key min max) +(defun validate-number (component value &key min max message-nan message-low message-hi) "Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE. If not a number, a localizable message \"Field ~a is not a valid number.\" is sent with key \"VALIDATE-NUMBER\". The argument for the message will be the :label attribute of the COMPONENT." @@ -134,10 +134,10 @@ (let ((test (numberp value))) (and (validate test :component component - :message (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") (label component))) - (validate-range component value :min min :max max))))) + :message (or message-nan (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") (label component)))) + (validate-range component value :min min :max max :message-low message-low :message-hi message-hi))))) -(defun validate-integer (component value &key min max) +(defun validate-integer (component value &key min max message-nan message-low message-hi) "Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE. If not a number, a localizable message \"Field ~a is not a valid integer.\" is sent with key \"VALIDATE-INTEGER\". The argument for the message will be the :label attribute of the COMPONENT." @@ -145,11 +145,11 @@ (let ((test (integerp value))) (and (validate test :component component - :message (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") (label component))) - (validate-range component value :min min :max max))))) + :message (or message-nan (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") (label component)))) + (validate-range component value :min min :max max :message-low message-low :message-hi message-hi))))) -(defun validate-date-range (component value &key min max (use-date-p t) use-time-p) +(defun validate-date-range (component value &key min max (use-date-p t) use-time-p message-low message-hi) "Checks if the input field VALUE is a date between min and max. If :USE-DATE-P is not nil and :USE-TIME-P is nil, validation is made without considering the time part of local-time. If :USE-DATE-P nil and :USE-TIME-P is not nil, validation is made without considering the date part of local-time. @@ -183,15 +183,15 @@ (and (when min (validate (local-time> new-value min) :component component - :message (format nil (do-message "VALIDATE-DATE-RANGE-MIN" "Field ~a is less then ~a.") - (label component) - (local-time-to-string min local-time-format)))) + :message (or message-low (format nil (do-message "VALIDATE-DATE-RANGE-MIN" "Field ~a is less then ~a.") + (label component) + (local-time-to-string min local-time-format))))) (when max (validate (local-time< new-value max) :component component - :message (format nil (do-message "VALIDATE-DATE-RANGE-MAX" "Field ~a is greater then ~a.") - (label component) - (local-time-to-string max local-time-format)))))))) + :message (or message-hi (format nil (do-message "VALIDATE-DATE-RANGE-MAX" "Field ~a is greater then ~a.") + (label component) + (local-time-to-string max local-time-format))))))))) @@ -213,16 +213,16 @@ (defmethod wcomponent-template ((exception-monitor exception-monitor)) (let ((client-id (htcomponent-client-id exception-monitor)) (validation-errors (validation-errors)) - (body (htcomponent-body exception-monitor))) + (body (htcomponent-body exception-monitor))) (div> :static-id client-id (wcomponent-informal-parameters exception-monitor) (when validation-errors (if body body - (ul> - (loop for component-exceptions in (rest validation-errors) by #'cddr - do (loop for message in component-exceptions - collect (li> message))))))))) + (ul> :id "errors" + (loop for (client-id component-exceptions) on validation-errors by #'cddr + collect (loop for message in component-exceptions + collect (li> message))))))))) ;;------------------------------------------------------------------------------------------- Modified: trunk/main/claw-core/tests/test1.lisp ============================================================================== --- trunk/main/claw-core/tests/test1.lisp (original) +++ trunk/main/claw-core/tests/test1.lisp Fri May 30 06:03:00 2008 @@ -46,10 +46,15 @@ (simple-message-dispatcher-add-message *lisplet-messages* "en" "NAME" "Name") (simple-message-dispatcher-add-message *lisplet-messages* "en" "SURNAME" "Surname") (simple-message-dispatcher-add-message *lisplet-messages* "en" "WELCOME" "Welcome") +(simple-message-dispatcher-add-message *lisplet-messages* "en" "AGREE" "Agree") +(simple-message-dispatcher-add-message *lisplet-messages* "en" "SURE" "Are you sure?") +(simple-message-dispatcher-add-message *lisplet-messages* "it" "YES" "sì") (simple-message-dispatcher-add-message *lisplet-messages* "it" "NAME" "Nome") (simple-message-dispatcher-add-message *lisplet-messages* "it" "SURNAME" "Cognome") (simple-message-dispatcher-add-message *lisplet-messages* "it" "WELCOME" "Benvenuto") +(simple-message-dispatcher-add-message *lisplet-messages* "it" "SURE" "Sei sicuro?") +(simple-message-dispatcher-add-message *lisplet-messages* "it" "SURE-ERROR-MESSAGE" "Devi essere sicuro") (simple-message-dispatcher-add-message *lisplet-messages* "it" "VALIDATE-REQUIRED" "Il campo ~a non può essere vuoto!") @@ -120,7 +125,7 @@ (title> (title o)) (style> :type "text/css" - "input.error { + "input.error, div.error { background-color: #FF9999; } ")) @@ -331,9 +336,13 @@ :accessor user-gender) (age :initarg :age :accessor user-age) + (agree :initarg :agree + :accessor user-agree) + (sure :initarg :sure + :accessor user-sure) (capital :initarg :capital :accessor user-capital)) - (:default-initargs :name "" :surname "" :gender "" :age "" :capital 0.0)) + (:default-initargs :name "" :surname "" :gender "" :age "" :capital 0.0 :sure "" :agree "")) (defgeneric form-page-update-user (form-page)) @@ -351,11 +360,14 @@ :accessor form-page-user) (age :initarg :age :accessor form-page-age) + (agree :initarg :agree + :accessor form-page-agree) + (sure :initarg :sure + :accessor form-page-sure) (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 @@ -364,6 +376,8 @@ :capital 500055/100 :birthday (now) :message-dispatcher *lisplet-messages* + :agree t + :sure "yes" :user (make-instance 'user))) (defmethod form-page-update-user ((form-page form-page)) @@ -371,113 +385,149 @@ (name (form-page-name form-page)) (surname (form-page-surname form-page)) (gender (form-page-gender form-page)) - (age (form-page-age form-page))) + (age (form-page-age form-page)) + (agree (form-page-agree form-page)) + (sure (form-page-sure form-page))) (setf (user-name user) name (user-surname user) surname (user-gender user) gender - (user-age user) age))) + (user-age user) age + (user-agree user) agree + (user-sure user) sure))) + - ;(defmethod message-dispatch ((object form-page) key locale) +(defun validate-agree (component value) + (declare (ignore value)) + (validate nil + :component component + :message (do-message "SURE-ERROR-MESSAGE" "You must be sure"))) -(defmethod page-content ((o form-page)) - (site-template> :title "a page title" - (cform> :id "testform" :method "post" :action #'form-page-update-user - (table> - (tr> - (td> "Name") - (td> - (cinput> :id "name" - :type "text" - :label "Name" - :validator #'(lambda (value) - (validate-required (page-current-component o) value)) - :accessor 'form-page-name)"*")) - (tr> :id "messaged" - (td> (with-message "SURNAME" "SURNAME")) - (td> - (cinput> :id "surname" - :type "text" - :label "Surname" - :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)"*")) - (tr> - (td> "Gender") - (td> - (cselect> :id "gender" - :accessor 'form-page-gender - (loop for gender in (list "M" "F") - collect (option> :value gender - (when (string= gender (form-page-gender o)) - '(:selected "selected")) - (if (string= gender "M") - "Male" - "Female")))))) - (tr> - (td> "Age") - (td> - (cinput> :id "age" - :type "text" - :label "Age" - :translator (make-instance 'translator-integer :thousand-separator #\') - :validator #'(lambda (value) - (let ((component (page-current-component o))) - (validate-required component value) - (validate-integer component value :min 1 :max 2000))) - :accessor 'form-page-age)"*")) - (tr> - (td> "Birthday") - (td> - (cinput> :id "bday" - :type "text" - :label "Birthday" - :translator (make-instance 'translator-date :local-time-format '(:date "-" :month "-" :year)) - :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)")) - (tr> - (td> "Capital") - (td> - (cinput> :id "capital" - :type "text" - :label "Capital" - :translator (make-instance 'translator-number - :decimal-digits 2 - :thousand-separator #\') - :validator #'(lambda (value) - (let ((component (page-current-component o))) - (validate-required component value) - (validate-number component value :min 1000.01 :max 500099/100))) - :accessor 'form-page-capital)"*")) - (tr> - (td> "Colors") - (td> - (cselect> :id "colors" - :multiple "true" - :style "width:80px;height:120px;" - :accessor 'form-page-colors - (loop for color in (list "R" "G" "B") - collect (option> :value color - (when (find color (form-page-colors o) :test #'string=) - '(:selected "selected")) - (cond - ((string= color "R") "red") - ((string= color "G") "green") - (t "blue"))))))) - (tr> - (td> :colspan "2" - (csubmit> :id "submit" :value "OK"))))) - (p> - (exception-monitor>) - (hr>) - (h2> "From result:") - (div> (format nil "Name: ~a" (user-name (form-page-user o)))) - (div> (format nil "Surname: ~a" (user-surname (form-page-user o)))) - (div> (format nil "Gender: ~a" (user-gender (form-page-user o)))) - (div> (format nil "Age: ~a" (user-age (form-page-user o))))))) +(defmethod page-content ((o form-page)) + (let ((user (form-page-user o))) + (site-template> :title "a page title" + (cform> :id "testform" :method "post" :action #'form-page-update-user + (table> + (tr> + (td> "Name") + (td> + (cinput> :id "name" + :type "text" + :label "Name" + :validator #'(lambda (value) + (validate-required (page-current-component o) value)) + :accessor 'form-page-name)"*")) + (tr> :id "messaged" + (td> (with-message "SURNAME" "SURNAME")) + (td> + (cinput> :id "surname" + :type "text" + :label "Surname" + :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)"*")) + (tr> :id "agree" + (td> (with-message "AGREE" "AGREE")) + (td> + (ccheckbox> :id "agree" + :label (with-message "AGREE" "AGREE") + :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" + :label (with-message "SURE" "SURE") + :accessor 'form-page-sure + :value "yes") + (span> :style "margin-right:1.5em;" (with-message "YES" "yes")) + (cradio> :id "sure" + :label (with-message "SURE" "SURE") + :validator #'(lambda (value) + (validate-agree (page-current-component o) value)) + :accessor 'form-page-sure + :value "no") + (span> :style "margin-right:1.5em;" (with-message "NO" "no")))) + (tr> + (td> "Gender") + (td> + (cselect> :id "gender" + :accessor 'form-page-gender + (loop for gender in (list "M" "F") + collect (option> :value gender + (when (string= gender (form-page-gender o)) + '(:selected "selected")) + (if (string= gender "M") + "Male" + "Female")))))) + (tr> + (td> "Age") + (td> + (cinput> :id "age" + :type "text" + :label "Age" + :translator (make-instance 'translator-integer :thousand-separator #\') + :validator #'(lambda (value) + (let ((component (page-current-component o))) + (validate-required component value) + (validate-integer component value :min 1 :max 2000))) + :accessor 'form-page-age)"*")) + (tr> + (td> "Birthday") + (td> + (cinput> :id "bday" + :type "text" + :label "Birthday" + :translator (make-instance 'translator-date :local-time-format '(:date "-" :month "-" :year)) + :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)")) + (tr> + (td> "Capital") + (td> + (cinput> :id "capital" + :type "text" + :label "Capital" + :translator (make-instance 'translator-number + :decimal-digits 2 + :thousand-separator #\') + :validator #'(lambda (value) + (let ((component (page-current-component o))) + (validate-required component value) + (validate-number component value :min 1000.01 :max 500099/100))) + :accessor 'form-page-capital)"*")) + (tr> + (td> "Colors") + (td> + (cselect> :id "colors" + :multiple "true" + :style "width:80px;height:120px;" + :accessor 'form-page-colors + (loop for color in (list "R" "G" "B") + collect (option> :value color + (when (find color (form-page-colors o) :test #'string=) + '(:selected "selected")) + (cond + ((string= color "R") "red") + ((string= color "G") "green") + (t "blue"))))))) + (tr> + (td> :colspan "2" + (csubmit> :id "submit" :value "OK"))))) + (p> + (exception-monitor> :class "error") + (hr>) + (h2> "From result:") + (div> (format nil "Name: ~a" (user-name user))) + (div> (format nil "Surname: ~a" (user-surname user))) + (div> (format nil "Gender: ~a" (user-gender user))) + (div> (format nil "Age: ~a" (user-age user))) + (div> (format nil "Agree: ~a" (user-agree user))) + (div> (format nil "Sure: ~a" (user-sure user))))))) (lisplet-register-page-location *test-lisplet* 'form-page "form.html")