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