1 (in-package :lisp-on-lines
)
3 (defstruct invalid-attribute-value
4 (initial-value nil
:read-only t
)
5 (invalid-value nil
:read-only t
)
6 (conditions nil
:read-only t
))
8 (deflayer validate
(editor))
10 (defcomponent validation-mixin
()
11 ((validation-conditions
12 :accessor validation-conditions
15 (inhibit-call-if-invalid-p
16 :accessor inhibit-call-if-invalid-p
18 :initarg
:inhibit-call-if-invalid-p
)
19 (inhibit-answer-if-invalid-p
20 :accessor inhibit-answer-if-invalid-p
22 :initarg
:inhibit-answer-if-invalid-p
)))
24 (defmethod render :wrap-around
((self validation-mixin
))
26 (setf (validation-conditions self
) nil
))
28 (defun component-valid-p (component)
29 (not (validation-conditions component
)))
31 (defmethod/cc call-component
:around
((from validation-mixin
) to
)
32 (if (inhibit-call-if-invalid-p from
)
33 (when (component-valid-p from
)
34 (call-next-method from to
))
35 (call-next-method from to
)))
37 (defmethod answer-component :around
((target validation-mixin
) value
)
38 (if (inhibit-answer-if-invalid-p target
)
39 (when (component-valid-p target
)
43 (defparameter *invalid-attribute-renderer
*
44 #'(lambda (invalid-attribute-value next-method
)
46 :class
"lol-invalid-attribute"
48 :class
"lol-invalid-attribute-message"
49 (dolist (c (invalid-attribute-value-conditions invalid-attribute-value
))
50 (<:li
(<:as-html
(message c
)))))
51 (funcall next-method
))))
53 (defattribute base-attribute
()
59 :required-test
'validate-string-exists
))
61 (defdisplay :in-layer validate
62 :around
((attribute base-attribute
) object
)
63 "Set the callback to perform validation
64 and create invalid-attribute-values when things don't validate. duh "
67 (ucw::make-new-callback
69 (setf (attribute-value object attribute
) val
)))))
70 ;;;; We need to lexically bind some slots here
71 ;;;; As by the time the validator runs we'll be in
72 ;;;; a totally different dynamic scope.
73 (validators (validate-using attribute
))
74 (label (label attribute
)))
76 ;;;; We have a convenience property for :requiredp
77 (when (requiredp attribute
)
78 (push (required-test attribute
) validators
))
80 ;;;; Now we create the validation callback
81 (dletf (((callback attribute
)
82 (ucw::make-new-callback
84 (flet ((setter (value)
86 (ucw::context.current-frame
*context
*)
90 ;; We have to do DLETF ,as we will no longer be
91 ;; in the validation layer at callback-application time.
92 (dletf (((validate-using attribute
) validators
)
93 ((slot-value attribute
'label
) label
))
94 (multiple-value-bind (validp conditions
)
95 (validate-attribute object attribute val
)
100 (make-invalid-attribute-value
101 :initial-value
(attribute-value object attribute
)
103 :conditions conditions
))
104 (when (subtypep (type-of self
) 'validation-mixin
)
105 (setf (validation-conditions self
)
106 (append conditions
(validation-conditions self
)))))))))))))
109 ;;;; Ok, so if the attribute-value holds an
110 ;;;; invalid-attribute-value struct, we take the appropriate action
111 (let ((value (attribute-value object attribute
)))
112 (if (invalid-attribute-value-p value
)
114 ;;;; set the value back the the previous
115 ;;;; TODO: does not handle unbound slots
117 (ucw::context.current-frame
*context
*)
119 (invalid-attribute-value-initial-value value
))
120 (funcall *invalid-attribute-renderer
*
123 (call-next-method))))
124 (call-next-method))))))