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 | ||
937d96b5 DC |
9 | ;;;; ** Attributes |
10 | (define-condition attribute-validation-condition (validation-condition) | |
11 | ((attribute :accessor attribute :initarg :attribute :initform nil))) | |
12 | ||
0cafb6ab | 13 | (defgeneric validate-attribute (instance attribute &optional value) |
937d96b5 DC |
14 | (:documentation " |
15 | 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.") | |
0cafb6ab | 16 | (:method (instance attribute &optional (value nil value-provided-p)) |
17 | (let ((val (if value-provided-p | |
18 | value | |
19 | (attribute-value instance attribute))) | |
20 | (conditions)) | |
21 | (handler-bind ((attribute-validation-condition | |
22 | #'(lambda (c) | |
23 | (setf conditions (cons c conditions)) | |
24 | (signal c)))) | |
25 | ||
26 | (dolist (f (find-validation-functions instance attribute)) | |
27 | (funcall f instance attribute val))) | |
28 | (if conditions | |
29 | (values nil conditions) | |
30 | t)))) | |
937d96b5 DC |
31 | |
32 | ||
33 | (defmethod find-validation-functions (instance (attribute standard-attribute)) | |
0cafb6ab | 34 | (let ((foo (validate-using attribute))) |
35 | (warn "validation?~A " foo) | |
36 | foo)) | |
937d96b5 DC |
37 | |
38 | ||
39 | ;;;; ** Instances | |
40 | (define-condition instance-validation-condition (validation-condition) | |
41 | ((instance :accessor instance :initarg instance :initform nil) | |
42 | (conditions :accessor conditions :initarg :conditions :initform nil))) | |
43 | ||
44 | (defmethod invalid-instance-p (instance attributes) | |
45 | (let (condition) | |
46 | (handler-bind ((instance-validation-condition | |
47 | #'(lambda (c) | |
48 | (setf condition c)))) | |
49 | (validate-instance instance attributes)) | |
50 | condition)) | |
51 | ||
52 | (defmethod validate-instance (instance attributes) | |
53 | (let (all-conditions) | |
54 | (dolist (att attributes) | |
55 | (multiple-value-bind (is-valid-p conditions) | |
56 | (validate-attribute instance att) | |
57 | (unless is-valid-p | |
58 | (setf all-conditions (nconc conditions all-conditions))))) | |
59 | (if all-conditions | |
60 | (progn (signal 'instance-validation-condition | |
61 | :message "Invalid Instance" | |
62 | :instance instance | |
63 | :conditions all-conditions) | |
64 | (values nil all-conditions)) | |
65 | ||
66 | t))) | |
67 | ||
0cafb6ab | 68 | |
937d96b5 DC |
69 | ;;;; Attribute Validation Functions |
70 | ;;;; I have not quite figured all this out yet. | |
71 | ;;;; A generic validation system needs more thought than i've given it, but this is a start. | |
72 | ||
0cafb6ab | 73 | (defun validate-string-exists (instance attribute value) |
937d96b5 DC |
74 | (if (or |
75 | (not (stringp value)) | |
76 | (not (< 0 (length value)))) | |
77 | (signal 'attribute-validation-condition | |
78 | :message (format nil "You must enter a value for ~A." | |
0cafb6ab | 79 | (label attribute)) |
80 | :attribute attribute))) | |
937d96b5 DC |
81 | |
82 | ||
0cafb6ab | 83 | (defun validate-true (instance attribute value) |
1e5d6797 | 84 | (unless value |
1e5d6797 | 85 | (signal 'attribute-validation-condition |
0cafb6ab | 86 | :message (format nil "~A is required." |
87 | (label attribute)) | |
8e9897fa | 88 | :attribute attribute))) |