| 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 | ;;;; ** Attributes |
| 10 | (define-condition attribute-validation-condition (validation-condition) |
| 11 | ((attribute :accessor attribute :initarg :attribute :initform nil))) |
| 12 | |
| 13 | (defgeneric validate-attribute (instance attribute &optional value) |
| 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.") |
| 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)))) |
| 31 | |
| 32 | |
| 33 | (defmethod find-validation-functions (instance (attribute standard-attribute)) |
| 34 | (let ((foo (validate-using attribute))) |
| 35 | (warn "validation?~A " foo) |
| 36 | foo)) |
| 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 | |
| 68 | |
| 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 | |
| 73 | (defun validate-string-exists (instance attribute value) |
| 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." |
| 79 | (label attribute)) |
| 80 | :attribute attribute))) |
| 81 | |
| 82 | |
| 83 | (defun validate-true (instance attribute value) |
| 84 | (unless value |
| 85 | (signal 'attribute-validation-condition |
| 86 | :message (format nil "~A is required." |
| 87 | (label attribute)) |
| 88 | :attribute attribute))) |