Commit | Line | Data |
---|---|---|
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 " | |
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) | |
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 | ||
84 |