Commit | Line | Data |
ddd87d75 |
1 | package MooseClass::Tests; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
5cab7e05 |
6 | use Lingua::EN::Inflect qw( A PL_N ); |
ddd87d75 |
7 | use Test::More 'no_plan'; |
8 | |
9 | sub tests01 { |
5cab7e05 |
10 | my %p = ( |
11 | person_attr_count => 2, |
12 | employee_attr_count => 3, |
13 | @_, |
14 | ); |
15 | |
ddd87d75 |
16 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
17 | |
18 | has_meta('Person'); |
19 | |
20 | check_isa( 'Person', ['Moose::Object'] ); |
21 | |
5cab7e05 |
22 | count_attrs( 'Person', $p{person_attr_count} ); |
ddd87d75 |
23 | |
24 | has_rw_attr( 'Person', $_ ) for qw( first_name last_name ); |
25 | |
26 | has_method( 'Person', 'full_name' ); |
27 | |
28 | no_droppings('Person'); |
29 | is_immutable('Person'); |
30 | |
31 | person01(); |
32 | |
33 | has_meta('Employee'); |
34 | |
35 | check_isa( 'Employee', [ 'Person', 'Moose::Object' ] ); |
36 | |
5cab7e05 |
37 | count_attrs( 'Employee', $p{employee_attr_count} ); |
ddd87d75 |
38 | |
8d1ce1d7 |
39 | has_rw_attr( 'Employee', $_ ) for qw( title salary ); |
ddd87d75 |
40 | has_ro_attr( 'Employee', 'ssn' ); |
41 | |
42 | has_overridden_method( 'Employee', 'full_name' ); |
43 | |
44 | employee01(); |
45 | } |
46 | |
5cab7e05 |
47 | sub tests02 { |
8d1ce1d7 |
48 | tests01( person_attr_count => 3, @_ ); |
5cab7e05 |
49 | |
50 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
51 | |
52 | no_droppings($_) for qw( Printable HasAccount ); |
53 | |
54 | does_role( 'Person', $_ ) for qw( Printable HasAccount ); |
55 | has_method( 'Person', $_ ) for qw( as_string deposit withdraw ); |
56 | has_rw_attr( 'Person', 'balance' ); |
57 | |
58 | does_role( 'Employee', $_ ) for qw( Printable HasAccount ); |
59 | |
60 | person02(); |
61 | employee02(); |
62 | } |
63 | |
8d1ce1d7 |
64 | sub tests03 { |
65 | { |
66 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
67 | |
68 | has_meta('Person'); |
69 | has_meta('Employee'); |
70 | |
71 | has_rw_attr( 'Person', 'title' ); |
72 | |
73 | has_rw_attr( 'Employee', 'title' ); |
74 | has_rw_attr( 'Employee', 'salary_level' ); |
75 | has_ro_attr( 'Employee', 'salary' ); |
76 | |
77 | has_method( 'Employee', '_build_salary' ); |
78 | } |
79 | |
80 | ok( ! Employee->meta->has_method('full_name'), |
81 | 'Employee no longer implements a full_name method' ); |
82 | |
83 | my $person_title_attr = Person->meta->get_attribute('title'); |
84 | ok( !$person_title_attr->is_required, 'title is not required in Person' ); |
85 | is( $person_title_attr->predicate, 'has_title', |
86 | 'Person title attr has a has_title predicate' ); |
87 | is( $person_title_attr->clearer, 'clear_title', |
88 | 'Person title attr has a clear_title clearer' ); |
89 | |
90 | my $balance_attr = Person->meta->get_attribute('balance'); |
91 | is( $balance_attr->default, 100, 'balance defaults to 100' ); |
92 | |
93 | my $employee_title_attr = Employee->meta->get_attribute('title'); |
94 | is( $employee_title_attr->default, 'Worker', |
95 | 'title defaults to Worker in Employee' ); |
96 | |
97 | my $salary_level_attr = Employee->meta->get_attribute('salary_level'); |
98 | is( $salary_level_attr->default, 1, 'salary_level defaults to 1' ); |
99 | |
100 | my $salary_attr = Employee->meta->get_attribute('salary'); |
101 | ok( !$salary_attr->init_arg, 'no init_arg for salary attribute' ); |
102 | ok( $salary_attr->has_builder, 'salary attr has a builder' ); |
103 | |
104 | person03(); |
105 | employee03(); |
106 | } |
107 | |
26164c8d |
108 | sub tests04 { |
109 | { |
110 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
111 | |
538499df |
112 | has_meta('Document'); |
113 | has_meta('Report'); |
114 | has_meta('TPSReport'); |
26164c8d |
115 | |
538499df |
116 | no_droppings('Document'); |
117 | no_droppings('Report'); |
118 | no_droppings('TPSReport'); |
119 | |
120 | has_ro_attr( 'Document', $_ ) for qw( title author ); |
121 | has_ro_attr( 'Report', 'summary' ); |
122 | has_ro_attr( 'TPSReport', $_ ) for qw( t p s ); |
123 | |
124 | has_method( 'Document', 'output' ); |
125 | has_augmented_method( 'Report', 'output' ); |
126 | has_augmented_method( 'TPSReport', 'output' ); |
26164c8d |
127 | } |
128 | |
538499df |
129 | my $tps = TPSReport->new( |
130 | title => 'That TPS Report', |
131 | author => 'Peter Gibbons (for Bill Lumberg)', |
132 | summary => 'I celebrate his whole collection!', |
133 | t => 'PC Load Letter', |
134 | p => 'Swingline', |
135 | s => 'flair!', |
136 | ); |
26164c8d |
137 | |
538499df |
138 | my $output = $tps->output; |
139 | $output =~ s/\n\n+/\n/g; |
26164c8d |
140 | |
538499df |
141 | is( $output, <<'EOF', 'output returns expected report' ); |
142 | That TPS Report |
143 | I celebrate his whole collection! |
144 | t: PC Load Letter |
145 | p: Swingline |
146 | s: flair! |
147 | Written by Peter Gibbons (for Bill Lumberg) |
148 | EOF |
26164c8d |
149 | } |
150 | |
66b226e5 |
151 | sub tests06 { |
152 | { |
153 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
154 | |
155 | has_meta('BankAccount'); |
156 | no_droppings('BankAccount'); |
157 | |
158 | has_rw_attr( 'BankAccount', 'balance' ); |
159 | has_rw_attr( 'BankAccount', 'owner' ); |
160 | has_ro_attr( 'BankAccount', 'history' ); |
161 | } |
162 | |
163 | my $person_meta = Person->meta; |
164 | ok( ! $person_meta->has_attribute('balance'), |
165 | 'Person class does not have a balance attribute' ); |
166 | |
167 | my $deposit_meth = $person_meta->get_method('deposit'); |
168 | isa_ok( $deposit_meth, 'Moose::Meta::Method::Delegation' ); |
169 | |
170 | my $withdraw_meth = $person_meta->get_method('withdraw'); |
171 | isa_ok( $withdraw_meth, 'Moose::Meta::Method::Delegation' ); |
172 | |
173 | my $ba_meta = BankAccount->meta; |
174 | ok( $ba_meta->get_attribute('owner')->is_weak_ref, |
175 | 'owner attribute is a weak ref' ); |
176 | |
177 | person06(); |
178 | } |
179 | |
180 | |
ddd87d75 |
181 | sub has_meta { |
182 | my $class = shift; |
183 | |
184 | ok( $class->can('meta'), "$class has a meta() method" ) |
185 | or BAIL_OUT("Cannot run tests against a class without a meta!"); |
186 | } |
187 | |
188 | sub check_isa { |
189 | my $class = shift; |
190 | my $parents = shift; |
191 | |
192 | my @isa = $class->meta->linearized_isa; |
193 | shift @isa; # returns $class as the first entry |
194 | |
195 | my $count = scalar @{$parents}; |
196 | my $noun = PL_N( 'parent', $count ); |
197 | |
198 | is( scalar @isa, $count, "$class has $count $noun" ); |
199 | |
200 | for ( my $i = 0; $i < @{$parents}; $i++ ) { |
201 | is( $isa[$i], $parents->[$i], "parent[$i] is $parents->[$i]" ); |
202 | } |
203 | } |
204 | |
205 | sub count_attrs { |
206 | my $class = shift; |
207 | my $count = shift; |
208 | |
209 | my $noun = PL_N( 'attribute', $count ); |
8d1ce1d7 |
210 | is( scalar $class->meta->get_attribute_list, $count, |
211 | "$class defines $count $noun" ); |
ddd87d75 |
212 | } |
213 | |
214 | sub has_rw_attr { |
215 | my $class = shift; |
216 | my $name = shift; |
217 | |
8d1ce1d7 |
218 | my $articled = A($name); |
5cab7e05 |
219 | ok( $class->meta->has_attribute($name), |
8d1ce1d7 |
220 | "$class has $articled attribute" ); |
ddd87d75 |
221 | |
222 | my $attr = $class->meta->get_attribute($name); |
223 | |
8d1ce1d7 |
224 | is( $attr->get_read_method, $name, |
225 | "$name attribute has a reader accessor - $name()" ); |
226 | is( $attr->get_write_method, $name, |
227 | "$name attribute has a writer accessor - $name()" ); |
ddd87d75 |
228 | } |
229 | |
230 | sub has_ro_attr { |
231 | my $class = shift; |
232 | my $name = shift; |
233 | |
8d1ce1d7 |
234 | my $articled = A($name); |
5cab7e05 |
235 | ok( $class->meta->has_attribute($name), |
8d1ce1d7 |
236 | "$class has $articled attribute" ); |
ddd87d75 |
237 | |
238 | my $attr = $class->meta->get_attribute($name); |
239 | |
8d1ce1d7 |
240 | is( $attr->get_read_method, $name, |
241 | "$name attribute has a reader accessor - $name()" ); |
242 | is( $attr->get_write_method, undef, |
243 | "$name attribute does not have a writer" ); |
ddd87d75 |
244 | } |
245 | |
246 | sub has_method { |
247 | my $class = shift; |
248 | my $name = shift; |
249 | |
8d1ce1d7 |
250 | my $articled = A($name); |
251 | ok( $class->meta->has_method($name), "$class has $articled method" ); |
ddd87d75 |
252 | } |
253 | |
254 | sub has_overridden_method { |
255 | my $class = shift; |
256 | my $name = shift; |
257 | |
8d1ce1d7 |
258 | my $articled = A($name); |
259 | ok( $class->meta->has_method($name), "$class has $articled method" ); |
ddd87d75 |
260 | |
261 | my $meth = $class->meta->get_method($name); |
262 | isa_ok( $meth, 'Moose::Meta::Method::Overridden' ); |
263 | } |
264 | |
538499df |
265 | sub has_augmented_method { |
266 | my $class = shift; |
267 | my $name = shift; |
268 | |
269 | my $articled = A($name); |
270 | ok( $class->meta->has_method($name), "$class has $articled method" ); |
271 | |
272 | my $meth = $class->meta->get_method($name); |
273 | isa_ok( $meth, 'Moose::Meta::Method::Augmented' ); |
274 | } |
275 | |
ddd87d75 |
276 | sub no_droppings { |
277 | my $class = shift; |
278 | |
279 | ok( !$class->can('has'), "no Moose droppings in $class" ); |
280 | } |
281 | |
282 | sub is_immutable { |
283 | my $class = shift; |
284 | |
285 | ok( $class->meta->is_immutable, "$class has been made immutable" ); |
286 | } |
287 | |
5cab7e05 |
288 | sub does_role { |
289 | my $class = shift; |
290 | my $role = shift; |
291 | |
292 | ok( $class->meta->does_role($role), "$class does the $role role" ); |
293 | } |
294 | |
ddd87d75 |
295 | sub person01 { |
296 | my $person = Person->new( |
297 | first_name => 'Bilbo', |
298 | last_name => 'Baggins', |
299 | ); |
300 | |
8d1ce1d7 |
301 | is( $person->full_name, 'Bilbo Baggins', |
302 | 'full_name() is correctly implemented' ); |
f7da468c |
303 | |
304 | $person = Person->new( [ qw( Lisa Smith ) ] ); |
305 | is( $person->first_name, 'Lisa', 'set first_name from two-arg arrayref' ); |
306 | is( $person->last_name, 'Smith', 'set last_name from two-arg arrayref' ); |
307 | |
308 | eval { Person->new( sub { 'foo' } ) }; |
309 | like( $@, qr/\QSingle parameters to new() must be a HASH ref/, |
310 | 'Person constructor still rejects bad parameters' ); |
ddd87d75 |
311 | } |
312 | |
313 | sub employee01 { |
314 | my $employee = Employee->new( |
315 | first_name => 'Amanda', |
316 | last_name => 'Palmer', |
8d1ce1d7 |
317 | title => 'Singer', |
ddd87d75 |
318 | ); |
319 | |
54b470f5 |
320 | my $called = 0; |
321 | my $orig_super = \&Employee::super; |
322 | no warnings 'redefine'; |
323 | local *Employee::super = sub { $called++; goto &$orig_super }; |
324 | |
f555d2ec |
325 | is( $employee->full_name, 'Amanda Palmer (Singer)', |
326 | 'full_name() is properly overriden in Employee' ); |
54b470f5 |
327 | ok( $called, 'Employee->full_name calls super()' ); |
ddd87d75 |
328 | } |
329 | |
5cab7e05 |
330 | sub person02 { |
331 | my $person = Person->new( |
332 | first_name => 'Bilbo', |
333 | last_name => 'Baggins', |
334 | balance => 0, |
335 | ); |
336 | |
8d1ce1d7 |
337 | is( $person->as_string, 'Bilbo Baggins', |
338 | 'as_string() is correctly implemented' ); |
5cab7e05 |
339 | |
340 | account_tests($person); |
341 | } |
342 | |
343 | sub employee02 { |
344 | my $employee = Employee->new( |
345 | first_name => 'Amanda', |
346 | last_name => 'Palmer', |
8d1ce1d7 |
347 | title => 'Singer', |
5cab7e05 |
348 | balance => 0, |
349 | ); |
350 | |
8d1ce1d7 |
351 | is( $employee->as_string, 'Amanda Palmer (Singer)', |
352 | 'as_string() uses overridden full_name method in Employee' ); |
5cab7e05 |
353 | |
354 | account_tests($employee); |
355 | } |
356 | |
8d1ce1d7 |
357 | sub person03 { |
358 | my $person = Person->new( |
359 | first_name => 'Bilbo', |
360 | last_name => 'Baggins', |
361 | ); |
362 | |
363 | is( $person->full_name, 'Bilbo Baggins', |
364 | 'full_name() is correctly implemented for a Person without a title' ); |
365 | ok( !$person->has_title, |
3647da1b |
366 | 'Person has_title predicate is working correctly (returns false)' ); |
8d1ce1d7 |
367 | |
368 | $person->title('Ringbearer'); |
3647da1b |
369 | ok( $person->has_title, 'Person has_title predicate is working correctly (returns true)' ); |
370 | |
3647da1b |
371 | my $called = 0; |
54b470f5 |
372 | my $orig_pred = \&Person::has_title; |
373 | no warnings 'redefine'; |
374 | local *Person::has_title = sub { $called++; goto &$orig_pred }; |
375 | |
8d1ce1d7 |
376 | is( $person->full_name, 'Bilbo Baggins (Ringbearer)', |
377 | 'full_name() is correctly implemented for a Person with a title' ); |
3647da1b |
378 | ok( $called, 'full_name in person uses the predicate for the title attribute' ); |
8d1ce1d7 |
379 | |
380 | $person->clear_title; |
381 | ok( !$person->has_title, 'Person clear_title method cleared the title' ); |
382 | |
383 | account_tests( $person, 100 ); |
384 | } |
385 | |
386 | sub employee03 { |
387 | my $employee = Employee->new( |
388 | first_name => 'Jimmy', |
389 | last_name => 'Foo', |
390 | salary_level => 3, |
391 | salary => 42, |
392 | ); |
393 | |
394 | is( $employee->salary, 30000, |
395 | 'salary is calculated from salary_level, and salary passed to constructor is ignored' ); |
396 | } |
397 | |
66b226e5 |
398 | sub person06 { |
399 | my $person = Person->new( |
400 | first_name => 'Bilbo', |
401 | last_name => 'Baggins', |
402 | ); |
403 | |
404 | isa_ok( $person->account, 'BankAccount' ); |
405 | is( $person->account->owner, $person, |
406 | 'owner of bank account is person that created account' ); |
407 | |
408 | $person->deposit(10); |
409 | is_deeply( $person->account->history, [ 100, 10 ], |
410 | 'deposit was recorded in account history' ); |
411 | |
412 | $person->withdraw(15); |
413 | is_deeply( $person->account->history, [ 100, 10, -15 ], |
414 | 'withdrawal was recorded in account history' ); |
415 | } |
416 | |
5cab7e05 |
417 | sub account_tests { |
418 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
419 | |
420 | my $person = shift; |
8d1ce1d7 |
421 | my $base_amount = shift || 0; |
5cab7e05 |
422 | |
423 | $person->deposit(50); |
8d1ce1d7 |
424 | eval { $person->withdraw( 75 + $base_amount ) }; |
425 | like( $@, qr/\QBalance cannot be negative/, |
426 | 'cannot withdraw more than is in our balance' ); |
5cab7e05 |
427 | |
8d1ce1d7 |
428 | $person->withdraw( 23 ); |
5cab7e05 |
429 | |
8d1ce1d7 |
430 | is( $person->balance, 27 + $base_amount, |
431 | 'balance is 27 (+ starting balance) after deposit of 50 and withdrawal of 23' ); |
5cab7e05 |
432 | } |
ddd87d75 |
433 | |
434 | 1; |