[claw-cvs] r13 - in trunk/main/claw-core: src tests
achiumenti at common-lisp.net
achiumenti at common-lisp.net
Tue Feb 19 11:24:12 UTC 2008
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")
More information about the Claw-cvs
mailing list