From 8e9897fa9349fbd230fd0f5f8c5a53afee3195cb Mon Sep 17 00:00:00 2001
From: drewc <drewc@tech.coop>
Date: Tue, 30 May 2006 20:05:45 -0700
Subject: [PATCH] More fixes and updates to validation system

darcs-hash:20060531030545-39164-23c86486062db06b9a3e71c92137c6fb648749b2.gz
---
 lisp-on-lines.asd                       |  6 +++
 src/validation/email-address.lisp       |  2 +-
 src/validation/standard-validation.lisp | 70 +++++++++++++++++++------
 src/validation/validation.lisp          |  7 +--
 4 files changed, 63 insertions(+), 22 deletions(-)

diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd
index 99b9a69..23446c9 100644
--- a/lisp-on-lines.asd
+++ b/lisp-on-lines.asd
@@ -33,6 +33,12 @@
 							   (: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))
diff --git a/src/validation/email-address.lisp b/src/validation/email-address.lisp
index 2a9ae3f..2f26127 100644
--- 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."
-			       (getf (description.properties attribute) :label))
+			       (label attribute))
 	      :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
--- a/src/validation/standard-validation.lisp
+++ b/src/validation/standard-validation.lisp
@@ -7,13 +7,38 @@
 
 (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)
@@ -25,6 +50,14 @@
 	       (<: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 
@@ -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)))
+    
+    ;;;; We have a convenience property for :requiredp
     (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)
@@ -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)
-			   ((slot-value attribute 'label) label)
-			   )
+			   ((slot-value attribute 'label) label))
 		     (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
diff --git a/src/validation/validation.lisp b/src/validation/validation.lisp
index dfdfca0..ab5961e 100644
--- 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))
-	      :attribute attribute))))
-
-
-
-
-
+	      :attribute attribute)))
\ No newline at end of file
-- 
2.20.1