Author: achiumenti Date: Tue Feb 19 06:24:12 2008 New Revision: 13 Modified: trunk/main/claw-core/src/components.lisp trunk/main/claw-core/src/misc.lisp trunk/main/claw-core/src/packages.lisp trunk/main/claw-core/src/tags.lisp trunk/main/claw-core/tests/test1.lisp Log: added beginning of validation support. added method page-current-component to page Modified: trunk/main/claw-core/src/components.lisp ============================================================================== --- trunk/main/claw-core/src/components.lisp (original) +++ trunk/main/claw-core/src/components.lisp Tue Feb 19 06:24:12 2008 @@ -40,33 +40,41 @@ (: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")) -(defmethod cform-rewinding-p ((obj cform) (pobj page)) - (string= (htcomponent-client-id obj) - (page-req-parameter pobj *rewind-parameter*))) - -(defmethod wcomponent-parameters ((o cform)) - (list :id :required :action nil)) - -(defmethod wcomponent-template((o cform)) - (let ((client-id (htcomponent-client-id o))) +(defmethod cform-rewinding-p ((cform cform) (page page)) + (string= (htcomponent-client-id cform) + (page-req-parameter page *rewind-parameter*))) + +(defmethod wcomponent-parameters ((cform cform)) + (list :id :required + :class nil + :action nil)) + +(defmethod wcomponent-template((cform cform)) + (let ((client-id (htcomponent-client-id cform)) + (class (wcomponent-parameter-value cform :class))) (when (null client-id) (setf client-id "")) + (when (null class) + (setf class "")) (form> :static-id client-id :name client-id - (wcomponent-informal-parameters o) + :class class + (wcomponent-informal-parameters cform) (input> :name *rewind-parameter* :type "hidden" :value client-id) - (htcomponent-body o)))) + (htcomponent-body cform)))) (defmethod wcomponent-before-rewind ((obj cform) (pobj page)) (setf (page-current-form pobj) obj)) (defmethod wcomponent-after-rewind ((obj cform) (pobj page)) - (let ((action (wcomponent-parameter-value obj :action))) - (unless (or (null action) (null (cform-rewinding-p obj pobj))) - (funcall (fdefinition action) pobj)) - (setf (page-current-form pobj) nil))) + (let ((validation-errors (aux-request-value :validation-errors)) + (action (wcomponent-parameter-value obj :action))) + (unless validation-errors + (when (or action (cform-rewinding-p obj pobj)) + (funcall (fdefinition action) pobj)) + (setf (page-current-form pobj) nil)))) ;-------------------------------------------------------------------------------- @@ -94,34 +102,54 @@ (:default-initargs :result-as-list nil) (:documentation "Request cycle aware component the renders as an INPUT tag class")) -(defmethod wcomponent-parameters ((o cinput)) - (list :id :required :reader nil :writer nil :visit-object nil :accessor nil :type :required)) +(defmethod wcomponent-parameters ((cinput cinput)) + (list :id :required + :reader nil + :writer nil + :visit-object nil + :accessor nil + :validator-handler nil + :class nil + :label nil + :validator nil + :type :required)) -(defmethod wcomponent-reserved-parameters ((o cinput)) +(defmethod wcomponent-reserved-parameters ((cinput cinput)) '(:value :name)) -(defmethod wcomponent-template ((obj cinput)) - (let ((client-id (htcomponent-client-id obj)) - (type (wcomponent-parameter-value obj :type)) - (visit-object (wcomponent-parameter-value obj :visit-object)) - (accessor (wcomponent-parameter-value obj :accessor)) - (reader (wcomponent-parameter-value obj :reader)) - (value "")) +(defmethod wcomponent-template ((cinput cinput)) + (let* ((client-id (htcomponent-client-id cinput)) + (type (wcomponent-parameter-value cinput :type)) + (visit-object (wcomponent-parameter-value cinput :visit-object)) + (accessor (wcomponent-parameter-value cinput :accessor)) + (reader (wcomponent-parameter-value cinput :reader)) + (class (wcomponent-parameter-value cinput :class)) + (value "") + (validation-errors (aux-request-value :validation-errors)) + (component-exceptions (assoc client-id validation-errors :test #'equal))) (when (null visit-object) - (setf visit-object (htcomponent-page obj))) + (setf visit-object (htcomponent-page cinput))) + (when (null class) + (setf class "")) + (when component-exceptions + (if (string= class "") + (setf class "error") + (setf class (format nil "~a error" class)))) (if (and (null reader) accessor) (setf value (funcall (fdefinition accessor) visit-object)) (setf value (funcall (fdefinition reader) visit-object))) (input> :static-id client-id :type type :name client-id + :class class :value value - (wcomponent-informal-parameters obj)))) + (wcomponent-informal-parameters cinput)))) (defmethod wcomponent-after-rewind ((obj cinput) (pobj page)) (let ((visit-object (wcomponent-parameter-value obj :visit-object)) (accessor (wcomponent-parameter-value obj :accessor)) - (writer (wcomponent-parameter-value obj :writer)) + (writer (wcomponent-parameter-value obj :writer)) + (validator (wcomponent-parameter-value obj :validator)) (new-value (page-req-parameter pobj (htcomponent-client-id obj) (cinput-result-as-list obj)))) @@ -130,7 +158,9 @@ (setf visit-object (htcomponent-page obj))) (if (and (null writer) accessor) (funcall (fdefinition `(setf ,accessor)) new-value visit-object) - (funcall (fdefinition writer) new-value visit-object))))) + (funcall (fdefinition writer) new-value visit-object)) + (when validator + (funcall validator))))) ;--------------------------------------------------------------------------------------- (defcomponent csubmit () () @@ -205,3 +235,55 @@ (wcomponent-informal-parameters obj) (htcomponent-body obj)))) + +(defun component-id-and-value (component) + (let ((client-id (htcomponent-client-id component)) + (visit-object (wcomponent-parameter-value component :visit-object)) + (accessor (wcomponent-parameter-value component :accessor)) + (reader (wcomponent-parameter-value component :reader)) + (value "")) + (when (null visit-object) + (setf visit-object (htcomponent-page component))) + (if (and (null reader) accessor) + (setf value (funcall (fdefinition accessor) visit-object)) + (setf value (funcall (fdefinition reader) visit-object))) + (values client-id value))) + +(defun add-exception (id reason) + (let* ((validation-errors (aux-request-value :validation-errors)) + (component-exceptions (assoc id validation-errors :test #'equal))) + (if component-exceptions + (push reason (cdr component-exceptions)) + (push (cons id (list reason)) + (aux-request-value :validation-errors))))) + +(defun validator-required (component) + (multiple-value-bind (client-id value) + (component-id-and-value component) + (when (or (null value) (string= value "")) + (add-exception client-id + (format nil "Field ~a may not be null." (wcomponent-parameter-value component :label)))))) + +;; ------------------------------------------------------------------------------------ +(defcomponent exce (cinput) () + (:default-initargs :result-as-list t) + (:documentation "This component renders as a normal SELECT tag class, +but it is request cycle aware.")) + +(defmethod wcomponent-parameters :around ((obj cselect)) + (declare (ignore obj)) + (let ((params (call-next-method))) + (remf params :reader) + (remf params :type) + params)) + +(defmethod wcomponent-reserved-parameters ((obj cselect)) + (declare (ignore obj)) + '(:type :name)) + +(defmethod wcomponent-template ((obj cselect)) + (let ((client-id (htcomponent-client-id obj))) + (select> :static-id client-id + :name client-id + (wcomponent-informal-parameters obj) + (htcomponent-body obj)))) \ No newline at end of file Modified: trunk/main/claw-core/src/misc.lisp ============================================================================== --- trunk/main/claw-core/src/misc.lisp (original) +++ trunk/main/claw-core/src/misc.lisp Tue Feb 19 06:24:12 2008 @@ -100,4 +100,4 @@ (defun login (&optional (request *request*)) "Perfoms a login action using the configuration object given for the request realm" - (configuration-login (current-config request))) \ No newline at end of file + (configuration-login (current-config request))) Modified: trunk/main/claw-core/src/packages.lisp ============================================================================== --- trunk/main/claw-core/src/packages.lisp (original) +++ trunk/main/claw-core/src/packages.lisp Tue Feb 19 06:24:12 2008 @@ -71,6 +71,7 @@ :page-indent :page-xmloutput :page-doc-type + :page-current-component :htclass-body :htcomponent :htcomponent-page @@ -219,6 +220,7 @@ :csubmit> :submit-link :submit-link> + :validator-required :lisplet :lisplet-realm :lisplet-pages Modified: trunk/main/claw-core/src/tags.lisp ============================================================================== --- trunk/main/claw-core/src/tags.lisp (original) +++ trunk/main/claw-core/src/tags.lisp Tue Feb 19 06:24:12 2008 @@ -109,6 +109,9 @@ See PAGE-BODY-INIT-SCRIPTS form more info. - PAGE is the page instance that must be given")) +(defgeneric page-current-component (page) + (:documentation "The component being processed into one of the rendering phases")) + (defgeneric htcomponent-rewind (htcomponent page) (:documentation "This internal method is the first called during the request cycle phase. It is evaluated when a form action or an action-link action is fired. It is used to update all visit objects slots. @@ -353,6 +356,9 @@ (json-component-count :initarg :json-component-count :accessor page-json-component-count :documentation "Need to render the json object after an xhr call.") (request-parameters :initarg :request-parameters) + (components-stack :initform nil + :accessor page-components-stack + :documentation "A stack of components enetered into rendering process.") (url :initarg :url :accessor page-url :documentation "The URL provided with this page instance")) (:default-initargs :writer t @@ -631,6 +637,8 @@ tag-list)) +(defmethod page-current-component ((page page)) + (car (page-components-stack page))) ;;;========= HTCOMPONENT ============================ (defmethod htcomponent-can-print ((htcomponent htcomponent)) (let* ((id (htcomponent-client-id htcomponent)) @@ -659,13 +667,25 @@ (page-format-raw page "\"")))) (defmethod htcomponent-rewind :before ((htcomponent htcomponent) (page page)) - (setf (htcomponent-page htcomponent) page)) + (setf (htcomponent-page htcomponent) page) + (push htcomponent (page-components-stack page))) (defmethod htcomponent-prerender :before ((htcomponent htcomponent) (page page)) - (setf (htcomponent-page htcomponent) page)) + (setf (htcomponent-page htcomponent) page) + (push htcomponent (page-components-stack page))) (defmethod htcomponent-render :before ((htcomponent htcomponent) (page page)) - (setf (htcomponent-page htcomponent) page)) + (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))) + +(defmethod htcomponent-render :after ((htcomponent htcomponent) (page page)) + (pop (page-components-stack page))) (defmethod htcomponent-rewind ((htcomponent htcomponent) (page page)) (dolist (tag (htcomponent-body htcomponent)) @@ -702,7 +722,7 @@ (loop for (k v) on (htcomponent-attributes tag) by #'cddr do (progn (assert (keywordp k)) - (when v + (when (and v (string-not-equal v "")) (page-format page " ~a=\"~a\"" (string-downcase (if (eq k :static-id) "id" @@ -890,16 +910,20 @@ :documentation "must be a plist or nil") (reserved-parameters :initarg :reserved-parameters :accessor wcomponent-reserved-parameters - :type cons :documentation "Parameters that may not be used in the constructor function") + :type cons + :documentation "Parameters that may not be used in the constructor function") (informal-parameters :initarg :informal-parameters :accessor wcomponent-informal-parameters - :type cons :documentation "Informal parameters are parameters optional for the component") + :type cons + :documentation "Informal parameters are parameters optional for the component") (allow-informal-parameters :initarg :allow-informal-parameters :reader wcomponent-allow-informal-parametersp - :allocation :class :documentation "Determines if the component accepts informal parameters") + :allocation :class + :documentation "Determines if the component accepts informal parameters") (template :initform nil :accessor wcomponent-template - :type htcomponent :documentation "The component template. What gives to each wcomponent its unique aspect and features")) + :type htcomponent + :documentation "The component template. What gives to each wcomponent its unique aspect and features")) (:default-initargs :informal-parameters nil :reserved-parameters nil :parameters nil Modified: trunk/main/claw-core/tests/test1.lisp ============================================================================== --- trunk/main/claw-core/tests/test1.lisp (original) +++ trunk/main/claw-core/tests/test1.lisp Tue Feb 19 06:24:12 2008 @@ -99,7 +99,12 @@ (html> (head> (title> - (wcomponent-parameter-value o ':title))) + (wcomponent-parameter-value o ':title)) + (style> :type "text/css" +"input.error { + background-color: #FF9999; +} +")) (body> (wcomponent-informal-parameters o) (div> @@ -113,7 +118,6 @@ (defmethod page-content ((page auth-page)) (site-template> :title "Unauth test page" (p> "not here"))) -; (claw-require-authorization)) (lisplet-register-page-location *test-lisplet* 'auth-page "unauth.html") (lisplet-protect *test-lisplet* "unauth.html" '("admin" "user")) @@ -233,7 +237,7 @@ (td> "Username") (td> (cinput> :id "username" - :type "text" + :type "text" :accessor 'login-page-username))) (tr> (td> "Password") @@ -256,38 +260,66 @@ (lisplet-register-page-location *test-lisplet* 'login-page "login.html" :login-page-p t) -(defclass form-page (page) +(defclass user () + ((name :initarg :name + :accessor user-name) + (surname :initarg :surname + :accessor user-surname) + (gender :initarg :gender + :accessor user-gender)) + (:default-initargs :name "" :surname "" :gender "")) + +(defgeneric form-page-update-user (form-page)) + +(defclass form-page (page user) ((name :initarg :name :accessor form-page-name) (surname :initarg :surname :accessor form-page-surname) - (gender :initarg :gender - :reader form-page-gender - :writer setf-gender) (colors :initarg :colors - :accessor form-page-colors)) - + :accessor form-page-colors) + (gender :initarg :gender + :writer setf-gender + :accessor form-page-gender) + (user :initarg :user + :accessor form-page-user)) (:default-initargs :name "kiuma" :surname "surnk" :colors nil - :gender '("M"))) + :gender '("M") + :user (make-instance 'user))) + +(defmethod form-page-update-user ((form-page form-page)) + (let ((user (form-page-user form-page)) + (name (form-page-name form-page)) + (surname (form-page-surname form-page)) + (gender (first (form-page-gender form-page)))) + (setf (user-name user) name + (user-surname user) surname + (user-gender user) gender))) (defmethod page-content ((o form-page)) (site-template> :title "a page title" - (cform> :id "testform" :method "post" + (cform> :id "testform" :method "post" :action 'form-page-update-user (table> (tr> (td> "Name") (td> (cinput> :id "name" :type "text" - :accessor 'form-page-name))) + :label "Name" + :validator #'(lambda () + (validator-required (page-current-component o))) + :accessor 'form-page-name)"*")) (tr> (td> "Surname") (td> (cinput> :id "surname" :type "text" - :accessor 'form-page-surname))) + :label "Name" + :validator #'(lambda () + (validator-required (page-current-component o))) + :accessor 'form-page-surname)"*")) (tr> (td> "Gender") (td> @@ -318,9 +350,12 @@ (tr> (td> :colspan "2" (csubmit> :id "submit" :value "OK"))))) - (div> (format nil "Name: ~a" (form-page-name o))) - (div> (format nil "Surname: ~a" (form-page-surname o))) - (div> (format nil "Gender: ~a" (first (form-page-gender o)))))) + (p> + (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))))))) (lisplet-register-page-location *test-lisplet* 'form-page "form.html")