Added NULL description and added :when option for attribute active
[clinton/lisp-on-lines.git] / src / attribute-test.lisp
CommitLineData
e7c5f95a 1(in-package :lol-test)
2
3(in-suite lisp-on-lines)
4
5(deftest test-attribute-value ()
6 (eval
7 '(progn
4358148e 8 (define-description attribute-test-description ()
e7c5f95a 9 ((attribute-1 :value "VALUE")
10 (attribute-2 :function (constantly "VALUE"))))
11
12 (deflayer attribute-test)
13
4358148e 14 (define-description attribute-test-description ()
e7c5f95a 15 ((attribute-1 :value "VALUE2")
16 (attribute-2 :function (constantly "VALUE2")))
17 (:in-layer . attribute-test))))
18
4358148e 19 (let ((d (find-description 'attribute-test-description)))
e8d4fa45 20 (dletf (((described-object d) nil))
e7c5f95a 21 (is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value)))
22
e7c5f95a 23 (with-active-layers (attribute-test)
e8d4fa45 24 (is (equalp (attribute-value (find-attribute d 'attribute-1))
25 (attribute-value (find-attribute d 'attribute-2))))
26 (is (equalp "VALUE2" (attribute-value (find-attribute d 'attribute-1))))))))
e7c5f95a 27
28(deftest test-attribute-property-inheriting ()
29 (test-attribute-value)
30 (eval '(progn
31 (deflayer attribute-property-test)
4358148e 32 (define-description attribute-test-description ()
e7c5f95a 33 ((attribute-1 :label "attribute1")
34 (attribute-2 :label "attribute2"))
35 (:in-layer . attribute-property-test))))
e7c5f95a 36 (with-active-layers (attribute-property-test)
4358148e 37 (let ((d (find-description 'attribute-test-description)))
e8d4fa45 38 (dletf (((described-object d) nil))
e7c5f95a 39
e8d4fa45 40 (is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value)))
e7c5f95a 41
e8d4fa45 42 (is (equalp "attribute1" (attribute-label (find-attribute d 'attribute-1))))
43 (is (equalp "attribute2" (attribute-label (find-attribute d 'attribute-2))))
e7c5f95a 44
45
e8d4fa45 46 (with-active-layers (attribute-test)
47 (is (equalp (attribute-value (find-attribute d 'attribute-1))
48 (attribute-value (find-attribute d 'attribute-2))))
49 (is (equalp "VALUE2" (attribute-value (find-attribute d 'attribute-1)))))))))
4358148e 50
81d70610 51(deftest (test-attribute-with-different-class :compile-before-run t) ()
4358148e 52 (eval '(progn
81d70610 53 (define-layered-class
54 test-attribute-class (lol::standard-attribute)
55 ((some-slot :initarg :some-slot
56 :layered t
57 :layered-accessor some-slot)))
58
4358148e 59 (define-description test-attribute-with-different-class-description ()
60 ((attribute-with-different-class :attribute-class test-attribute-class :some-slot "BRILLANT!")))))
61
62 (let* ((d (find-description 'test-attribute-with-different-class-description))
63
64 (a (find-attribute d 'attribute-with-different-class)))
65 (is (eq (class-of a)
66 (find-class 'test-attribute-class)))
67 (is (equalp "BRILLANT!" (some-slot a)))))
68
b7657b86 69(deftest (test-attribute-with-different-class-and-subclassed-description :compile-before-run t) ()
70 (test-attribute-with-different-class)
71 (eval '(progn
72 (define-description test-attribute-with-different-class-description-sub
73 (test-attribute-with-different-class-description)
74 ())))
75
76 (let* ((d (find-description 'test-attribute-with-different-class-description-sub))
77
78 (a (find-attribute d 'attribute-with-different-class)))
79 (is (eq (class-of a)
80 (find-class 'test-attribute-class)))
81 (is (equalp "BRILLANT!" (some-slot a)))))
82
4358148e 83
84
e7c5f95a 85
86
87
88