+++ /dev/null
-(in-package :lisp-on-lines)
-
-;;;; Validation Conditions
-
-(define-condition validation-condition ()
- ((message :accessor message :initarg :message :initform "Invalid value")
- (value :accessor value :initarg :value :initform (warn "condition was not given a value"))))
-
-;;;; ** Attributes
-(define-condition attribute-validation-condition (validation-condition)
- ((attribute :accessor attribute :initarg :attribute :initform nil)))
-
-(defgeneric validate-attribute (instance attribute &optional value)
- (:documentation "
-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.")
- (:method (instance attribute &optional (value nil value-provided-p))
- (let ((val (if value-provided-p
- value
- (attribute-value instance attribute)))
- (conditions))
- (handler-bind ((attribute-validation-condition
- #'(lambda (c)
- (setf conditions (cons c conditions))
- (signal c))))
-
- (dolist (f (find-validation-functions instance attribute))
- (funcall f instance attribute val)))
- (if conditions
- (values nil conditions)
- t))))
-
-
-(defmethod find-validation-functions (instance (attribute standard-attribute))
- (let ((foo (validate-using attribute)))
- (warn "validation?~A " foo)
- foo))
-
-
-;;;; ** Instances
-(define-condition instance-validation-condition (validation-condition)
- ((instance :accessor instance :initarg instance :initform nil)
- (conditions :accessor conditions :initarg :conditions :initform nil)))
-
-(defmethod invalid-instance-p (instance attributes)
- (let (condition)
- (handler-bind ((instance-validation-condition
- #'(lambda (c)
- (setf condition c))))
- (validate-instance instance attributes))
- condition))
-
-(defmethod validate-instance (instance attributes)
- (let (all-conditions)
- (dolist (att attributes)
- (multiple-value-bind (is-valid-p conditions)
- (validate-attribute instance att)
- (unless is-valid-p
- (setf all-conditions (nconc conditions all-conditions)))))
- (if all-conditions
- (progn (signal 'instance-validation-condition
- :message "Invalid Instance"
- :instance instance
- :conditions all-conditions)
- (values nil all-conditions))
-
- t)))
-
-
-;;;; Attribute Validation Functions
-;;;; I have not quite figured all this out yet.
-;;;; A generic validation system needs more thought than i've given it, but this is a start.
-
-(defun validate-string-exists (instance attribute value)
- (if (or
- (not (stringp value))
- (not (< 0 (length value))))
- (signal 'attribute-validation-condition
- :message (format nil "You must enter a value for ~A."
- (label attribute))
- :attribute attribute)))
-
-
-(defun validate-true (instance attribute value)
- (unless value
- (signal 'attribute-validation-condition
- :message (format nil "~A is required."
- (label attribute))
- :attribute attribute)))
\ No newline at end of file