├── .gitignore
├── README.org
├── src
    └── main.lisp
├── tests
    └── main.lisp
└── validated-class.asd


/.gitignore:
--------------------------------------------------------------------------------
 1 | *.abcl
 2 | *.fasl
 3 | *.dx32fsl
 4 | *.dx64fsl
 5 | *.lx32fsl
 6 | *.lx64fsl
 7 | *.x86f
 8 | *~
 9 | .#*
10 | 


--------------------------------------------------------------------------------
/README.org:
--------------------------------------------------------------------------------
 1 | #+TITLE: validated-class
 2 | 
 3 | The ~validated-class~ metaclass provides a ~:validators~ slot parameter. ~:validators~ takes a list of one or more predicates which are run on object creation and slot updates. Failed validators signal the ~validation-error~ condition.
 4 | 
 5 | * Usage
 6 | #+begin_src common-lisp
 7 |   (defun less-than-5? (value)
 8 |     (< (length value) 5))
 9 | 
10 |   (defclass test-class ()
11 |     ((foo :initarg :foo
12 |           :accessor foo
13 |           :validators (stringp less-than-5?)))
14 |     (:metaclass validated-class))
15 | 
16 |   ;; CL-USER> (make-instance 'test-class :foo 123)
17 |   ;; STRINGP failed when setting FOO to 123
18 |   ;;    [Condition of type VALIDATION-ERROR]
19 |   ;;
20 |   ;; CL-USER> (make-instance 'test-class :foo "12345")
21 |   ;; LESS-THAN-5? failed when setting FOO to 12345
22 |   ;;    [Condition of type VALIDATION-ERROR]
23 |   ;;
24 |   ;; CL-USER> (make-instance 'test-class :foo "1234")
25 |   ;; #<TEST-CLASS {7007E09133}>
26 | #+end_src
27 | 
28 | * Other implementations worth exploring
29 | - [[https://www.hexstreamsoft.com/libraries/canonicalized-initargs/][canonicalized-initargs]]
30 | 


--------------------------------------------------------------------------------
/src/main.lisp:
--------------------------------------------------------------------------------
 1 | (uiop:define-package validated-class
 2 |   (:use #:cl)
 3 |   (:export :validated-class :validation-error))
 4 | (in-package #:validated-class)
 5 | 
 6 | (define-condition validation-error (error)
 7 |   ((validator :initarg :validator
 8 |               :initform (error "validator is required")
 9 |               :accessor validator)
10 |    (slot-name :initarg :slot-name
11 |               :initform (error "slot-name is required")
12 |               :accessor slot-name)
13 |    (value :initarg :value
14 |           :initform (error "value is required")))
15 |   (:report (lambda (condition stream)
16 |              (with-slots (validator slot-name value) condition
17 |                (format stream "~a failed when setting ~a to ~a"
18 |                        validator slot-name value)))))
19 | 
20 | (defclass validated-slot-definition ()
21 |   ((validators :initarg :validators :accessor validators :initform nil)))
22 | 
23 | (defclass validated-class-standard-direct-slot-definition
24 |     (validated-slot-definition c2mop:standard-direct-slot-definition)
25 |   ())
26 | 
27 | (defclass validated-class-standard-effective-slot-definition
28 |     (validated-slot-definition c2mop:standard-effective-slot-definition)
29 |   ())
30 | 
31 | (defclass validated-class (standard-class)
32 |   ())
33 | 
34 | (defmethod c2mop:validate-superclass
35 |     ((class validated-class) (superclass standard-class))
36 |   t)
37 | 
38 | (defmethod c2mop:direct-slot-definition-class ((class validated-class) &rest initargs)
39 |   (declare (ignore initargs))
40 |   (find-class 'validated-class-standard-direct-slot-definition))
41 | 
42 | (defmethod c2mop:effective-slot-definition-class ((class validated-class) &rest initargs)
43 |   (declare (ignore initargs))
44 |   (find-class 'validated-class-standard-effective-slot-definition))
45 | 
46 | (defmethod c2mop:compute-effective-slot-definition
47 |     ((class validated-class) slot-name direct-slot-definitions)
48 |   (let ((effective-slot-definition (call-next-method)))
49 |     (setf (validators effective-slot-definition)
50 |           (some #'validators direct-slot-definitions))
51 |     effective-slot-definition))
52 | 
53 | (defmethod (setf c2mop:slot-value-using-class) :before
54 |     (new-value (class validated-class) instance slot)
55 |   (dolist (validator (validators slot))
56 |     (unless (ignore-errors (funcall validator new-value))
57 |       (error 'validation-error :validator validator
58 |                                :slot-name (c2mop:slot-definition-name slot)
59 |                                :value new-value))))
60 | 


--------------------------------------------------------------------------------
/tests/main.lisp:
--------------------------------------------------------------------------------
 1 | (defpackage validated-class/tests/main
 2 |   (:use :cl :validated-class :rove))
 3 | 
 4 | (in-package :validated-class/tests/main)
 5 | 
 6 | ;; NOTE: To run this test file, execute `(asdf:test-system :validated-class)' in your Lisp.
 7 | 
 8 | (defun less-than-5? (value)
 9 |   (< (length value) 5))
10 | 
11 | (defclass test-class ()
12 |   ((foo :initarg :foo
13 |         :accessor foo
14 |         :type string
15 |         :validators (stringp less-than-5?))
16 |    (bar :initarg :bar
17 |         :accessor bar))
18 |   (:metaclass validated-class))
19 | 
20 | (deftest test-validated-class
21 |   (testing "creating object"
22 |     (ok (make-instance 'test-class :foo "foo" :bar 123))
23 |     (ok (signals (make-instance 'test-class :foo 1/2 :bar 123)))
24 |     (ok (signals (make-instance 'test-class :foo "12345" :bar 123))))
25 |   (testing "setting object slots"
26 |     (let ((obj (make-instance 'test-class :foo "foo" :bar 123)))
27 |       (ok (setf (foo obj) "1234"))
28 |       (ok (signals (setf (foo obj) 1234)))
29 |       (ok (signals (setf (foo obj) "12345")))
30 |       (ok (setf (bar obj) 1234)))))
31 | 


--------------------------------------------------------------------------------
/validated-class.asd:
--------------------------------------------------------------------------------
 1 | (defsystem "validated-class"
 2 |   :version "0.0.1"
 3 |   :author "cvdub"
 4 |   :license "MIT"
 5 |   :depends-on ("closer-mop")
 6 |   :components ((:module "src"
 7 |                 :components
 8 |                 ((:file "main"))))
 9 |   :description "CLOS metaclass supporting class and slot validation"
10 |   :in-order-to ((test-op (test-op "validated-class/tests"))))
11 | 
12 | (defsystem "validated-class/tests"
13 |   :author "cvdub"
14 |   :license "MIT"
15 |   :depends-on ("validated-class"
16 |                "rove")
17 |   :components ((:module "tests"
18 |                 :components
19 |                 ((:file "main"))))
20 |   :description "Test system for validated-class"
21 |   :perform (test-op (op c) (symbol-call :rove :run c)))
22 | 


--------------------------------------------------------------------------------