stray paren in last patch
[clinton/lisp-on-lines.git] / src / validation.lisp
CommitLineData
937d96b5
DC
1(in-package :lisp-on-lines)
2
3;;;; Validation Conditions
4
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"))))
8
9
10;;;; ** Attributes
11(define-condition attribute-validation-condition (validation-condition)
12 ((attribute :accessor attribute :initarg :attribute :initform nil)))
13
14(defgeneric validate-attribute (instance attribute)
15 (:documentation "
16Returns 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)
18 (let (conditions)
19 (handler-bind ((attribute-validation-condition
20 #'(lambda (c)
21 (setf conditions (cons c conditions))
22 (signal c))))
23 (dolist (f (find-validation-functions instance attribute))
24 (funcall f instance attribute)))
25 (if conditions
26 (values nil conditions)
27 t)))
28 (:method (instance (attribute symbol))
29 (validate-attribute instance (find-attribute instance attribute))))
30
31
32(defmethod find-validation-functions (instance (attribute standard-attribute))
33 (getf (attribute.plist attribute) :validate-using))
34
35
36;;;; ** Instances
37(define-condition instance-validation-condition (validation-condition)
38 ((instance :accessor instance :initarg instance :initform nil)
39 (conditions :accessor conditions :initarg :conditions :initform nil)))
40
41(defmethod invalid-instance-p (instance attributes)
42 (let (condition)
43 (handler-bind ((instance-validation-condition
44 #'(lambda (c)
45 (setf condition c))))
46 (validate-instance instance attributes))
47 condition))
48
49(defmethod validate-instance (instance attributes)
50 (let (all-conditions)
51 (dolist (att attributes)
52 (multiple-value-bind (is-valid-p conditions)
53 (validate-attribute instance att)
54 (unless is-valid-p
55 (setf all-conditions (nconc conditions all-conditions)))))
56 (if all-conditions
57 (progn (signal 'instance-validation-condition
58 :message "Invalid Instance"
59 :instance instance
60 :conditions all-conditions)
61 (values nil all-conditions))
62
63 t)))
64
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.
68
69(defun validate-string-exists (instance attribute)
70 (let ((value (lol::attribute-value instance attribute)))
71 (if (or
72 (not (stringp value))
73 (not (< 0 (length value))))
74 (signal 'attribute-validation-condition
75 :message (format nil "You must enter a value for ~A."
76 (getf (attribute.plist attribute) :label))
77 :attribute attribute))))
78
79
80
81
82
83
bb547d37
DC
84
85