+++ /dev/null
-(in-package :lisp-on-lines)
-
-;;;; This file contains various hacks that maintain backwards
-;;;; compat for programs written in older versions of LoL.
-
-;;;; While we try to maintain this, some things just require breaking
-;;;; with the past. You learn to live with it.
-
-
-(defmethod find-old-type (type)
- type)
-
-;;!legacy string
-(defmethod find-attribute-class-for-type ((type (eql 'mewa-string)))
- 'string-attribute)
-;; legacy int
-(defmethod find-attribute-class-for-type ((type (eql 'mewa-integer)))
- 'integer-attribute)
-
-;; currency
-(defmethod find-attribute-class-for-type ((type (eql 'mewa-currency)))
- 'currency-attribute)
-;; legacy relations
-
-(defmethod find-attribute-class-for-type ((type (eql 'ajax-foreign-key)))
- 'lol::has-a)
-
-
-(defmethod find-attribute-class-for-type ((type (eql 'foreign-key)))
- 'lol::has-a)
-
-(defmethod find-layer-for-type ((type (eql 'mewa-one-line-presentation)))
- 'one-line)
-
-(defmethod find-old-type ((type (eql 'one-line)))
- 'mewa-one-line-presentation)
-
-(defmethod find-old-type ((type (eql 'one-line)))
- 'mewa-one-line-presentation)
-
-
-
-
-
+++ /dev/null
-(in-package :lol)
-
-;; I lifted this regexp from http://www.ex-parrot.com/~pdw/Mail-RFC822-Address
-
-;; this is the copyright :
-
-;; COPYRIGHT and LICENSE
-
-;; This program is copyright 2001-2002 by Paul Warren.
-
-;; Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the ``Software''), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
-
-;; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-
-(defparameter *email-regexp*
- "(?:(?:\\r\\n)?[ \\t])*(?:(?:(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*))*@(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*))*|(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*)*\\<(?:(?:\\r\\n)?[ \\t])*(?:@(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*))*(?:,@(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*))*)*:(?:(?:\\r\\n)?[ \\t])*)?(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*))*@(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*))*\\>(?:(?:\\r\\n)?[ \\t])*)|(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*)*:(?:(?:\\r\\n)?[ \\t])*(?:(?:(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*))*@(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*))*|(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*)*\\<(?:(?:\\r\\n)?[ \\t])*(?:@(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*))*(?:,@(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*))*)*:(?:(?:\\r\\n)?[ \\t])*)?(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*))*@(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*))*\\>(?:(?:\\r\\n)?[ \\t])*)(?:,\\s*(?:(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*))*@(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*))*|(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*)*\\<(?:(?:\\r\\n)?[ \\t])*(?:@(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*))*(?:,@(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*))*)*:(?:(?:\\r\\n)?[ \\t])*)?(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*))*@(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*))*\\>(?:(?:\\r\\n)?[ \\t])*))*)?;\\s*)")
-
-(defun validate-email-address (instance attribute)
- (let ((value (lol::attribute-value instance attribute)))
- (if (or
- (not (stringp value))
- (not (< 0 (length value))))
- (signal 'attribute-validation-condition
- :message (format nil "You must enter a value for ~A."
- (getf (description.properties attribute) :label))
- :attribute attribute))))
\ No newline at end of file
(defvar scanner (cl-ppcre:create-scanner +email-regexp+))
-(defun validate-email-address (instance attribute)
- (let ((value (lol::attribute-value instance attribute)))
- (multiple-value-bind (start end)
- (cl-ppcre:scan scanner value)
- (when (not (and (equal start 0) (equal end (length value))))
- (signal 'attribute-validation-condition
- :message (format nil "~A must be a valid email address."
- (getf (description.properties attribute) :label))
- :attribute attribute)))))
\ No newline at end of file
+(defun validate-email-address (instance attribute value)
+ (multiple-value-bind (start end)
+ (cl-ppcre:scan scanner value)
+ (when (not (and (equal start 0) (equal end (length value))))
+ (signal 'attribute-validation-condition
+ :message (format nil "~A must be a valid email address."
+ (getf (description.properties attribute) :label))
+ :attribute attribute))))
\ No newline at end of file
--- /dev/null
+(in-package :lisp-on-lines)
+
+(defstruct invalid-attribute-value
+ (initial-value nil :read-only t)
+ (invalid-value nil :read-only t)
+ (conditions nil :read-only t))
+
+(deflayer validate (editor))
+
+(defattribute base-attribute ()
+ ()
+ (:in-layer validate)
+ (:default-properties
+ :validate-using nil
+ :requiredp nil
+ :required-test 'validate-true))
+
+(defparameter *invalid-attribute-renderer*
+ #'(lambda (invalid-attribute-value next-method)
+ (<:div
+ :class "lol-invalid-attribute"
+ (<:ul
+ :class "lol-invalid-attribute-message"
+ (dolist (c (invalid-attribute-value-conditions invalid-attribute-value))
+ (<:li (<:as-html (message c)))))
+ (funcall next-method))))
+
+(defdisplay :in-layer validate
+ :around ((attribute base-attribute) object)
+ "Set the callback to perform validation
+and create invalid-attribute-values when things don't validate. duh "
+ (let ((callback (or
+ (callback attribute)
+ (ucw::make-new-callback
+ #'(lambda (val)
+ (setf (attribute-value object attribute) val)))))
+ ;;;; We need to lexically bind some slots here
+ ;;;; As by the time the validator runs we'll be in
+ ;;;; a totally different dynamic scope.
+ (validators (validate-using attribute))
+ (label (label attribute)))
+ (when (requiredp attribute)
+ (push (required-test attribute) validators))
+ (dletf (((callback attribute)
+ (ucw::make-new-callback
+ #'(lambda (val)
+ (flet ((setter (value)
+ (ucw::call-callback
+ (ucw::context.current-frame *context*)
+ callback
+ value)))
+
+ ;; We have to do DLETF ,as we will no longer be
+ ;; in the validation layer at callback-application time.
+ (dletf (((validate-using attribute) validators)
+ ((slot-value attribute 'label) label)
+ )
+ (multiple-value-bind (validp conditions)
+ (validate-attribute object attribute val)
+ (if validp
+ (setter val)
+ (setter
+ (make-invalid-attribute-value
+ :initial-value (attribute-value object attribute)
+ :invalid-value val
+ :conditions conditions))))))))))
+
+
+ ;;;; Ok, so if the attribute-value holds an
+ ;;;; invalid-attribute-value struct, we take the appropriate action
+ (let ((value (attribute-value object attribute)))
+ (if (invalid-attribute-value-p value)
+ (progn
+ ;;;; set the value back the the previous
+ ;;;; TODO: does not handle unbound slots
+ (ucw::call-callback
+ (ucw::context.current-frame *context*)
+ callback
+ (invalid-attribute-value-initial-value value))
+ (funcall *invalid-attribute-renderer*
+ value
+ #'(lambda ()
+ (call-next-method))))
+ (call-next-method))))))
\ No newline at end of file
((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)
+(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)
- (let (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)))
- (if conditions
- (values nil conditions)
- t)))
- (:method (instance (attribute symbol))
- (validate-attribute instance (find-attribute instance attribute))))
+ (: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))
- (getf (description.properties attribute) :validate-using))
+ (let ((foo (validate-using attribute)))
+ (warn "validation?~A " foo)
+ foo))
;;;; ** Instances
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)
- (let ((value (lol::attribute-value instance attribute)))
+(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."
- (getf (description.properties attribute) :label))
- :attribute attribute))))
+ (label attribute))
+ :attribute attribute)))
-(defun validate-true (instance attribute)
-
- (warn "validate ~A ~A" instance attribute)
- (let ((value (lol::attribute-value instance attribute)))
- (warn "value is ~A" value)
+(defun validate-true (instance attribute value)
(unless value
-
(signal 'attribute-validation-condition
- :message (format nil "~A must be true."
- (getf (description.properties attribute) :label))
+ :message (format nil "~A is required."
+ (label attribute))
:attribute attribute))))
HCoop / clinton / lisp-on-lines.git / commitdiff