Commit | Line | Data |
0f24a39d |
1 | package SharedTests; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
6 | use Scalar::Util qw( isweak ); |
54a288bd |
7 | use Test::More; |
8 | |
9 | my $HasMXAH; |
10 | BEGIN |
11 | { |
12 | if ( eval 'use MooseX::AttributeHelpers; 1;' ) |
13 | { |
14 | $HasMXAH = 1; |
15 | } |
16 | } |
17 | |
18 | plan tests => 25; |
0f24a39d |
19 | |
20 | |
21 | { |
22 | package HasClassAttribute; |
23 | |
24 | use Moose; |
25 | use MooseX::ClassAttribute; |
26 | |
54a288bd |
27 | use vars qw($Lazy); |
28 | $Lazy = 0; |
29 | |
30 | class_has 'ObjectCount' => |
31 | ( is => 'rw', |
0f24a39d |
32 | isa => 'Int', |
33 | default => 0, |
34 | ); |
35 | |
54a288bd |
36 | class_has 'WeakAttribute' => |
37 | ( is => 'rw', |
0f24a39d |
38 | isa => 'Object', |
39 | weak_ref => 1, |
40 | ); |
41 | |
54a288bd |
42 | class_has 'LazyAttribute' => |
43 | ( is => 'rw', |
44 | isa => 'Int', |
45 | lazy => 1, |
46 | # The side effect is used to test that this was called |
47 | # lazily. |
48 | default => sub { $Lazy = 1 }, |
49 | ); |
50 | |
51 | class_has 'ReadOnlyAttribute' => |
52 | ( is => 'ro', |
53 | isa => 'Int', |
54 | default => 10, |
55 | ); |
56 | |
57 | class_has 'ManyNames' => |
58 | ( is => 'rw', |
59 | isa => 'Int', |
60 | reader => 'M', |
61 | writer => 'SetM', |
62 | clearer => 'ClearM', |
63 | predicate => 'HasM', |
64 | ); |
65 | |
66 | class_has 'Delegatee' => |
67 | ( is => 'rw', |
68 | isa => 'Delegatee', |
69 | handles => [ 'units', 'color' ], |
70 | default => sub { Delegatee->new() }, |
71 | ); |
72 | |
73 | if ($HasMXAH) |
74 | { |
75 | class_has 'Mapping' => |
76 | ( metaclass => 'Collection::Hash', |
77 | is => 'rw', |
78 | isa => 'HashRef[Str]', |
79 | default => sub { {} }, |
80 | provides => |
81 | { exists => 'ExistsInMapping', |
82 | keys => 'IdsInMapping', |
83 | get => 'GetMapping', |
84 | set => 'SetMapping', |
85 | }, |
86 | ); |
87 | } |
88 | |
0f24a39d |
89 | has 'size' => |
90 | ( is => 'rw', |
91 | isa => 'Int', |
92 | default => 5, |
93 | ); |
94 | |
54a288bd |
95 | no Moose; |
96 | no MooseX::ClassAttribute; |
97 | |
0f24a39d |
98 | sub BUILD |
99 | { |
6b059c78 |
100 | my $self = shift; |
0f24a39d |
101 | |
6b059c78 |
102 | $self->ObjectCount( $self->ObjectCount() + 1 ); |
0f24a39d |
103 | } |
54a288bd |
104 | |
105 | sub make_immutable |
106 | { |
107 | my $class = shift; |
108 | |
109 | $class->meta()->make_immutable(); |
110 | MooseX::ClassAttribute::container_class()->meta()->make_immutable(); |
111 | Delegatee->meta()->make_immutable(); |
112 | } |
113 | } |
114 | |
115 | { |
116 | package Delegatee; |
117 | |
118 | use Moose; |
119 | |
120 | has 'units' => |
121 | ( is => 'ro', |
122 | default => 5, |
123 | ); |
124 | |
125 | has 'color' => |
126 | ( is => 'ro', |
127 | default => 'blue', |
128 | ); |
129 | } |
130 | |
131 | { |
132 | package Child; |
133 | |
134 | use Moose; |
135 | use MooseX::ClassAttribute; |
136 | |
137 | extends 'HasClassAttribute'; |
138 | |
139 | class_has '+ReadOnlyAttribute' => |
140 | ( default => 30 ); |
0f24a39d |
141 | } |
142 | |
143 | sub run_tests |
144 | { |
145 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
146 | |
147 | { |
148 | is( HasClassAttribute->ObjectCount(), 0, |
149 | 'ObjectCount() is 0' ); |
150 | |
151 | my $hca1 = HasClassAttribute->new(); |
152 | is( $hca1->size(), 5, |
153 | 'size is 5 - object attribute works as expected' ); |
154 | is( HasClassAttribute->ObjectCount(), 1, |
155 | 'ObjectCount() is 1' ); |
156 | |
157 | my $hca2 = HasClassAttribute->new( size => 10 ); |
158 | is( $hca2->size(), 10, |
159 | 'size is 10 - object attribute can be set via constructor' ); |
160 | is( HasClassAttribute->ObjectCount(), 2, |
161 | 'ObjectCount() is 2' ); |
162 | is( $hca2->ObjectCount(), 2, |
163 | 'ObjectCount() is 2 - can call class attribute accessor on object' ); |
164 | } |
165 | |
166 | { |
54a288bd |
167 | my $hca3 = HasClassAttribute->new( ObjectCount => 20 ); |
168 | is( $hca3->ObjectCount(), 3, |
169 | 'class attributes passed to the constructor do not get set in the object' ); |
170 | is( HasClassAttribute->ObjectCount(), 3, |
0f24a39d |
171 | 'class attributes are not affected by constructor params' ); |
172 | } |
173 | |
174 | { |
175 | my $object = bless {}, 'Thing'; |
176 | |
177 | HasClassAttribute->WeakAttribute($object); |
178 | |
6b059c78 |
179 | undef $object; |
180 | |
181 | ok( ! defined HasClassAttribute->WeakAttribute(), |
0f24a39d |
182 | 'weak class attributes are weak' ); |
183 | } |
54a288bd |
184 | |
185 | { |
186 | is( $HasClassAttribute::Lazy, 0, |
187 | '$HasClassAttribute::Lazy is 0' ); |
188 | |
189 | is( HasClassAttribute->LazyAttribute(), 1, |
190 | 'HasClassAttribute->LazyAttribute() is 1' ); |
191 | |
192 | is( $HasClassAttribute::Lazy, 1, |
193 | '$HasClassAttribute::Lazy is 1 after calling LazyAttribute' ); |
194 | } |
195 | |
196 | { |
197 | eval { HasClassAttribute->ReadOnlyAttribute(20) }; |
198 | like( $@, qr/\QCannot assign a value to a read-only accessor/, |
199 | 'cannot set read-only class attribute' ); |
200 | } |
201 | |
202 | { |
203 | is( Child->ReadOnlyAttribute(), 30, |
204 | q{Child class can extend parent's class attribute} ); |
205 | } |
206 | |
207 | { |
208 | ok( ! HasClassAttribute->HasM(), |
209 | 'HasM() returns false before M is set' ); |
210 | |
211 | HasClassAttribute->SetM(22); |
212 | |
213 | ok( HasClassAttribute->HasM(), |
214 | 'HasM() returns true after M is set' ); |
215 | is( HasClassAttribute->M(), 22, |
216 | 'M() returns 22' ); |
217 | |
218 | HasClassAttribute->ClearM(); |
219 | |
220 | ok( ! HasClassAttribute->HasM(), |
221 | 'HasM() returns false after M is cleared' ); |
222 | } |
223 | |
224 | { |
225 | isa_ok( HasClassAttribute->Delegatee(), 'Delegatee', |
226 | 'has a Delegetee object' ); |
227 | is( HasClassAttribute->units(), 5, |
228 | 'units() delegates to Delegatee and returns 5' ); |
229 | } |
230 | |
231 | { |
232 | ok( ! HasClassAttribute->can('class_has'), |
233 | q{'no MooseX::ClassAttribute' remove class_has from HasClassAttribute} ); |
234 | } |
235 | |
236 | SKIP: |
237 | { |
238 | skip 'These tests require MooseX::AttributeHelpers', 4 |
239 | unless $HasMXAH; |
240 | |
241 | my @ids = HasClassAttribute->IdsInMapping(); |
242 | is( scalar @ids, 0, |
243 | 'there are no keys in the mapping yet' ); |
244 | |
245 | ok( ! HasClassAttribute->ExistsInMapping('a'), |
246 | 'key does not exist in mapping' ); |
247 | |
248 | HasClassAttribute->SetMapping( a => 20 ); |
249 | |
250 | ok( HasClassAttribute->ExistsInMapping('a'), |
251 | 'key does exist in mapping' ); |
252 | |
253 | is( HasClassAttribute->GetMapping('a'), 20, |
254 | 'value for a in mapping is 20' ); |
255 | } |
0f24a39d |
256 | } |
257 | |
258 | |
259 | 1; |