1 (in-package :lisp-on-lines
)
3 ;;;; Validation Conditions
5 (define-condition validation-condition
()
6 ((message :accessor message
:initarg
:message
:initform
"Invalid value")
7 (value :accessor value
:initarg
:value
:initform
(warn "condition was not given a value"))))
11 (define-condition attribute-validation-condition
(validation-condition)
12 ((attribute :accessor attribute
:initarg
:attribute
:initform nil
)))
14 (defgeneric validate-attribute
(instance attribute
)
16 Returns T if the ATTRIBUTE-VALUE in INSTANCE passes all the validation functions. Otherwise, returns (values nil conditions) where CONDITIONS is a list of conditions representing the validation errors the slot.")
17 (:method
(instance attribute
)
19 (handler-bind ((attribute-validation-condition
21 (setf conditions
(cons c conditions
))
23 (dolist (f (find-validation-functions instance attribute
))
24 (funcall f instance attribute
)))
26 (values nil conditions
)
28 (:method
(instance (attribute symbol
))
29 (validate-attribute instance
(find-attribute instance attribute
))))
32 (defmethod find-validation-functions (instance (attribute standard-attribute
))
33 (getf (description.properties attribute
) :validate-using
))
37 (define-condition instance-validation-condition
(validation-condition)
38 ((instance :accessor instance
:initarg instance
:initform nil
)
39 (conditions :accessor conditions
:initarg
:conditions
:initform nil
)))
41 (defmethod invalid-instance-p (instance attributes
)
43 (handler-bind ((instance-validation-condition
46 (validate-instance instance attributes
))
49 (defmethod validate-instance (instance attributes
)
51 (dolist (att attributes
)
52 (multiple-value-bind (is-valid-p conditions
)
53 (validate-attribute instance att
)
55 (setf all-conditions
(nconc conditions all-conditions
)))))
57 (progn (signal 'instance-validation-condition
58 :message
"Invalid Instance"
60 :conditions all-conditions
)
61 (values nil all-conditions
))
65 ;;;; Attribute Validation Functions
66 ;;;; I have not quite figured all this out yet.
67 ;;;; A generic validation system needs more thought than i've given it, but this is a start.
69 (defun validate-string-exists (instance attribute
)
70 (let ((value (lol::attribute-value instance attribute
)))
73 (not (< 0 (length value
))))
74 (signal 'attribute-validation-condition
75 :message
(format nil
"You must enter a value for ~A."
76 (getf (description.properties attribute
) :label
))
77 :attribute attribute
))))
80 (defun validate-true (instance attribute
)
82 (warn "validate ~A ~A" instance attribute
)
83 (let ((value (lol::attribute-value instance attribute
)))
84 (warn "value is ~A" value
)
87 (signal 'attribute-validation-condition
88 :message
(format nil
"~A must be true."
89 (getf (description.properties attribute
) :label
))
90 :attribute attribute
))))