X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/0cafb6ab55d78bf3888b28363c3ef527cd3620a7..e9c163726f466dee83a8dbe7d952f6aaff4345b6:/src/validation/standard-validation.lisp

diff --git a/src/validation/standard-validation.lisp b/src/validation/standard-validation.lisp
index b719262..3d616f2 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 base-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