More fixes and updates to validation system

darcs-hash:20060531030545-39164-23c86486062db06b9a3e71c92137c6fb648749b2.gz

diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd
index 99b9a69..23446c9 100644 (file)
--- a/lisp-on-lines.asd
+++ b/lisp-on-lines.asd
@@ -33,6 +33,12 @@
                                                           (:file "relational-attributes")
                                                           (:file "dojo-attributes"))
                                              :serial t)
                                                           (:file "relational-attributes")
                                                           (:file "dojo-attributes"))
                                              :serial t)

+                                    (:module :validation
+                                             :components
+                                             ((:file "validation")
+                                              (:file "standard-validation")
+                                              (:file "email-address"))
+                                             :serial t)

                                     (:module :components
                                              :components ((:file "crud"))))
                        :serial t))
                                     (:module :components
                                              :components ((:file "crud"))))
                        :serial t))

diff --git a/src/validation/email-address.lisp b/src/validation/email-address.lisp
index 2a9ae3f..2f26127 100644 (file)
--- a/src/validation/email-address.lisp
+++ b/src/validation/email-address.lisp
@@ -23,5 +23,5 @@
     (when (not (and (equal start 0) (equal end (length value))))
       (signal 'attribute-validation-condition
              :message (format nil "~A must be a valid email address."
     (when (not (and (equal start 0) (equal end (length value))))
       (signal 'attribute-validation-condition
              :message (format nil "~A must be a valid email address."

-                              (getf (description.properties attribute) :label))
+                              (label attribute))

              :attribute attribute))))
\ No newline at end of file
              :attribute attribute))))
\ No newline at end of file

diff --git a/src/validation/standard-validation.lisp b/src/validation/standard-validation.lisp
index b719262..8856b07 100644 (file)
--- a/src/validation/standard-validation.lisp
+++ b/src/validation/standard-validation.lisp
@@ -7,13 +7,38 @@
 
 (deflayer validate (editor))
 
 
 (deflayer validate (editor))
 

-(defattribute base-attribute ()
-  ()
-  (:in-layer validate)
-  (:default-properties
-      :validate-using nil
-    :requiredp nil
-    :required-test 'validate-true))
+(defcomponent validation-mixin ()
+  ((validation-conditions
+    :accessor validation-conditions
+    :initform nil
+    :backtrack t)
+   (inhibit-call-if-invalid-p
+    :accessor inhibit-call-if-invalid-p
+    :initform t
+    :initarg :inhibit-call-if-invalid-p)
+   (inhibit-answer-if-invalid-p
+    :accessor inhibit-answer-if-invalid-p
+    :initform t
+    :initarg :inhibit-answer-if-invalid-p)))
+
+(defmethod render :wrap-around ((self validation-mixin))
+  (call-next-method)
+  (setf (validation-conditions self) nil))
+
+(defun component-valid-p (component)
+  (not (validation-conditions component)))
+
+(defmethod/cc call-component :around ((from validation-mixin) to)
+   (if (inhibit-call-if-invalid-p from)
+      (when (component-valid-p from)
+       (call-next-method from to))
+      (call-next-method from to)))
+
+(defmethod answer-component :around ((target validation-mixin) value)
+  (if (inhibit-answer-if-invalid-p target)
+      (when (component-valid-p target)
+       (call-next-method))
+      (call-next-method)))

 
 (defparameter *invalid-attribute-renderer*
   #'(lambda (invalid-attribute-value next-method)
 
 (defparameter *invalid-attribute-renderer*
   #'(lambda (invalid-attribute-value next-method)


@@ -25,6 +50,14 @@
               (<:li (<:as-html (message c)))))
            (funcall next-method))))
 
               (<:li (<:as-html (message c)))))
            (funcall next-method))))
 

+(defattribute string-attribute ()
+  ()
+  (:in-layer validate)
+  (:default-properties
+      :validate-using nil
+    :requiredp nil
+    :required-test 'validate-string-exists))
+

 (defdisplay :in-layer validate
            :around ((attribute base-attribute) object)
   "Set the callback to perform validation 
 (defdisplay :in-layer validate
            :around ((attribute base-attribute) object)
   "Set the callback to perform validation 


@@ -39,9 +72,13 @@ and create invalid-attribute-values when things don't validate. duh "
        ;;;; a totally different dynamic scope.
        (validators (validate-using attribute))
        (label (label attribute)))
        ;;;; a totally different dynamic scope.
        (validators (validate-using attribute))
        (label (label attribute)))

+    
+    ;;;; We have a convenience property for :requiredp

     (when (requiredp attribute)
       (push (required-test attribute) validators))
     (when (requiredp attribute)
       (push (required-test attribute) validators))

-   (dletf (((callback attribute)
+
+    ;;;; Now we create the validation callback
+    (dletf (((callback attribute)

            (ucw::make-new-callback
             #'(lambda (val)
                 (flet ((setter (value)
            (ucw::make-new-callback
             #'(lambda (val)
                 (flet ((setter (value)


@@ -53,17 +90,20 @@ and create invalid-attribute-values when things don't validate. duh "
                 ;; We have to do DLETF ,as we will no longer be
                 ;; in the validation layer at callback-application time. 
                   (dletf (((validate-using attribute) validators)
                 ;; We have to do DLETF ,as we will no longer be
                 ;; in the validation layer at callback-application time. 
                   (dletf (((validate-using attribute) validators)

-                          ((slot-value attribute 'label) label)
-                          )
+                          ((slot-value attribute 'label) label))

                     (multiple-value-bind (validp conditions)
                         (validate-attribute object attribute val)
                       (if validp
                           (setter val)
                     (multiple-value-bind (validp conditions)
                         (validate-attribute object attribute val)
                       (if validp
                           (setter val)

-                          (setter
-                           (make-invalid-attribute-value
-                            :initial-value (attribute-value object attribute)
-                            :invalid-value val
-                            :conditions conditions))))))))))
+                          (progn
+                            (setter
+                             (make-invalid-attribute-value
+                              :initial-value (attribute-value object attribute)
+                              :invalid-value val
+                              :conditions conditions))
+                            (when (subtypep (type-of self) 'validation-mixin)
+                              (setf (validation-conditions self)
+                                    (append conditions (validation-conditions self)))))))))))))

 
 
      ;;;; Ok, so if the attribute-value holds an
 
 
      ;;;; Ok, so if the attribute-value holds an

diff --git a/src/validation/validation.lisp b/src/validation/validation.lisp
index dfdfca0..ab5961e 100644 (file)
--- a/src/validation/validation.lisp
+++ b/src/validation/validation.lisp
@@ -85,9 +85,4 @@ Returns T if the ATTRIBUTE-VALUE in INSTANCE passes all the validation functions
       (signal 'attribute-validation-condition
              :message (format nil "~A is required."
                               (label attribute))
       (signal 'attribute-validation-condition
              :message (format nil "~A is required."
                               (label attribute))

-             :attribute attribute))))
-
-
-
-
-
+             :attribute attribute)))
\ No newline at end of file