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 { |
10 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
11 | |
12 | has_meta('Person'); |
13 | |
14 | check_isa( 'Person', ['Moose::Object'] ); |
15 | |
ddd87d75 |
16 | has_rw_attr( 'Person', $_ ) for qw( first_name last_name ); |
17 | |
18 | has_method( 'Person', 'full_name' ); |
19 | |
20 | no_droppings('Person'); |
21 | is_immutable('Person'); |
22 | |
23 | person01(); |
24 | |
25 | has_meta('Employee'); |
26 | |
27 | check_isa( 'Employee', [ 'Person', 'Moose::Object' ] ); |
28 | |
8d1ce1d7 |
29 | has_rw_attr( 'Employee', $_ ) for qw( title salary ); |
ddd87d75 |
30 | has_ro_attr( 'Employee', 'ssn' ); |
31 | |
32 | has_overridden_method( 'Employee', 'full_name' ); |
33 | |
34 | employee01(); |
35 | } |
36 | |
5cab7e05 |
37 | sub tests02 { |
a8c37857 |
38 | tests01(); |
5cab7e05 |
39 | |
40 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
41 | |
42 | no_droppings($_) for qw( Printable HasAccount ); |
43 | |
44 | does_role( 'Person', $_ ) for qw( Printable HasAccount ); |
45 | has_method( 'Person', $_ ) for qw( as_string deposit withdraw ); |
46 | has_rw_attr( 'Person', 'balance' ); |
47 | |
48 | does_role( 'Employee', $_ ) for qw( Printable HasAccount ); |
49 | |
50 | person02(); |
51 | employee02(); |
52 | } |
53 | |
8d1ce1d7 |
54 | sub tests03 { |
55 | { |
56 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
57 | |
58 | has_meta('Person'); |
59 | has_meta('Employee'); |
60 | |
61 | has_rw_attr( 'Person', 'title' ); |
62 | |
605c1144 |
63 | has_rw_attr( 'Employee', 'title', 'overridden' ); |
8d1ce1d7 |
64 | has_rw_attr( 'Employee', 'salary_level' ); |
65 | has_ro_attr( 'Employee', 'salary' ); |
66 | |
67 | has_method( 'Employee', '_build_salary' ); |
68 | } |
69 | |
70 | ok( ! Employee->meta->has_method('full_name'), |
71 | 'Employee no longer implements a full_name method' ); |
72 | |
73 | my $person_title_attr = Person->meta->get_attribute('title'); |
74 | ok( !$person_title_attr->is_required, 'title is not required in Person' ); |
75 | is( $person_title_attr->predicate, 'has_title', |
76 | 'Person title attr has a has_title predicate' ); |
77 | is( $person_title_attr->clearer, 'clear_title', |
78 | 'Person title attr has a clear_title clearer' ); |
79 | |
80 | my $balance_attr = Person->meta->get_attribute('balance'); |
81 | is( $balance_attr->default, 100, 'balance defaults to 100' ); |
82 | |
83 | my $employee_title_attr = Employee->meta->get_attribute('title'); |
84 | is( $employee_title_attr->default, 'Worker', |
85 | 'title defaults to Worker in Employee' ); |
86 | |
87 | my $salary_level_attr = Employee->meta->get_attribute('salary_level'); |
88 | is( $salary_level_attr->default, 1, 'salary_level defaults to 1' ); |
89 | |
90 | my $salary_attr = Employee->meta->get_attribute('salary'); |
91 | ok( !$salary_attr->init_arg, 'no init_arg for salary attribute' ); |
92 | ok( $salary_attr->has_builder, 'salary attr has a builder' ); |
93 | |
94 | person03(); |
95 | employee03(); |
96 | } |
97 | |
26164c8d |
98 | sub tests04 { |
99 | { |
100 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
101 | |
538499df |
102 | has_meta('Document'); |
103 | has_meta('Report'); |
104 | has_meta('TPSReport'); |
26164c8d |
105 | |
538499df |
106 | no_droppings('Document'); |
107 | no_droppings('Report'); |
108 | no_droppings('TPSReport'); |
109 | |
110 | has_ro_attr( 'Document', $_ ) for qw( title author ); |
111 | has_ro_attr( 'Report', 'summary' ); |
112 | has_ro_attr( 'TPSReport', $_ ) for qw( t p s ); |
113 | |
114 | has_method( 'Document', 'output' ); |
115 | has_augmented_method( 'Report', 'output' ); |
116 | has_augmented_method( 'TPSReport', 'output' ); |
26164c8d |
117 | } |
118 | |
538499df |
119 | my $tps = TPSReport->new( |
120 | title => 'That TPS Report', |
121 | author => 'Peter Gibbons (for Bill Lumberg)', |
122 | summary => 'I celebrate his whole collection!', |
123 | t => 'PC Load Letter', |
124 | p => 'Swingline', |
125 | s => 'flair!', |
126 | ); |
26164c8d |
127 | |
538499df |
128 | my $output = $tps->output; |
129 | $output =~ s/\n\n+/\n/g; |
26164c8d |
130 | |
538499df |
131 | is( $output, <<'EOF', 'output returns expected report' ); |
132 | That TPS Report |
133 | I celebrate his whole collection! |
134 | t: PC Load Letter |
135 | p: Swingline |
136 | s: flair! |
137 | Written by Peter Gibbons (for Bill Lumberg) |
138 | EOF |
26164c8d |
139 | } |
140 | |
ad648c43 |
141 | sub tests05 { |
142 | { |
143 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
144 | |
145 | has_meta('Person'); |
146 | has_meta('Employee'); |
147 | no_droppings('Employee'); |
148 | } |
149 | |
150 | for my $attr_name ( qw( first_name last_name title ) ) { |
151 | my $attr = Person->meta->get_attribute($attr_name); |
152 | |
153 | ok( $attr->has_type_constraint, |
154 | "Person $attr_name has a type constraint" ); |
155 | is( $attr->type_constraint->name, 'Str', |
156 | "Person $attr_name type is Str" ); |
157 | } |
158 | |
159 | { |
160 | my $salary_level_attr = Employee->meta->get_attribute('salary_level'); |
161 | ok( $salary_level_attr->has_type_constraint, |
162 | 'Employee salary_level has a type constraint' ); |
163 | |
164 | my $tc = $salary_level_attr->type_constraint; |
165 | |
166 | for my $invalid ( 0, 11, -14, 'foo', undef ) { |
167 | my $str = defined $invalid ? $invalid : 'undef'; |
168 | ok( ! $tc->check($invalid), |
169 | "salary_level type rejects invalid value - $str" ); |
170 | } |
171 | |
172 | for my $valid ( 1..10 ) { |
173 | ok( $tc->check($valid), |
174 | "salary_level type accepts valid value - $valid" ); |
175 | } |
176 | } |
177 | |
178 | { |
179 | my $salary_attr = Employee->meta->get_attribute('salary'); |
180 | |
181 | ok( $salary_attr->has_type_constraint, |
182 | 'Employee salary has a type constraint' ); |
183 | |
184 | my $tc = $salary_attr->type_constraint; |
185 | |
186 | for my $invalid ( 0, -14, 'foo', undef ) { |
187 | my $str = defined $invalid ? $invalid : 'undef'; |
188 | ok( ! $tc->check($invalid), |
189 | "salary type rejects invalid value - $str" ); |
190 | } |
191 | |
192 | for my $valid ( 1, 100_000, 10**10 ) { |
193 | ok( $tc->check($valid), |
194 | "salary type accepts valid value - $valid" ); |
195 | } |
196 | } |
197 | |
198 | { |
199 | my $ssn_attr = Employee->meta->get_attribute('ssn'); |
200 | |
201 | ok( $ssn_attr->has_type_constraint, |
202 | 'Employee ssn has a type constraint' ); |
203 | |
204 | my $tc = $ssn_attr->type_constraint; |
205 | |
206 | for my $invalid ( 0, -14, 'foo', undef, '123-ab-1241', '123456789' ) { |
207 | my $str = defined $invalid ? $invalid : 'undef'; |
208 | ok( ! $tc->check($invalid), |
209 | "ssn type rejects invalid value - $str" ); |
210 | } |
211 | |
212 | for my $valid ( '041-12-1251', '123-45-6789', '926-41-5820' ) { |
213 | ok( $tc->check($valid), |
214 | "ssn type accepts valid value - $valid" ); |
215 | } |
216 | } |
217 | } |
218 | |
66b226e5 |
219 | sub tests06 { |
220 | { |
221 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
222 | |
5c7cd208 |
223 | has_meta('Person'); |
224 | has_meta('Employee'); |
66b226e5 |
225 | has_meta('BankAccount'); |
226 | no_droppings('BankAccount'); |
227 | |
228 | has_rw_attr( 'BankAccount', 'balance' ); |
229 | has_rw_attr( 'BankAccount', 'owner' ); |
230 | has_ro_attr( 'BankAccount', 'history' ); |
231 | } |
232 | |
36e1e336 |
233 | my $ba_meta = BankAccount->meta; |
234 | ok( $ba_meta->has_attribute('balance'), |
235 | 'BankAccount class has a balance attribute' ); |
236 | |
ed84c5c6 |
237 | my $history_attr = $ba_meta->get_attribute('history'); |
238 | |
239 | ok( |
240 | $history_attr->meta() |
241 | ->does_role('Moose::Meta::Attribute::Native::Trait::Array'), |
242 | 'BankAccount history attribute uses native delegation to an array ref' |
243 | ); |
244 | |
36e1e336 |
245 | ok( $ba_meta->get_attribute('balance')->has_trigger, |
246 | 'BankAccount balance attribute has a trigger' ); |
247 | |
66b226e5 |
248 | my $person_meta = Person->meta; |
249 | ok( ! $person_meta->has_attribute('balance'), |
250 | 'Person class does not have a balance attribute' ); |
251 | |
252 | my $deposit_meth = $person_meta->get_method('deposit'); |
253 | isa_ok( $deposit_meth, 'Moose::Meta::Method::Delegation' ); |
254 | |
255 | my $withdraw_meth = $person_meta->get_method('withdraw'); |
256 | isa_ok( $withdraw_meth, 'Moose::Meta::Method::Delegation' ); |
257 | |
66b226e5 |
258 | ok( $ba_meta->get_attribute('owner')->is_weak_ref, |
259 | 'owner attribute is a weak ref' ); |
260 | |
261 | person06(); |
262 | } |
263 | |
264 | |
ddd87d75 |
265 | sub has_meta { |
266 | my $class = shift; |
267 | |
5c7cd208 |
268 | use_ok($class) |
269 | or BAIL_OUT("$class cannot be loaded"); |
270 | |
ddd87d75 |
271 | ok( $class->can('meta'), "$class has a meta() method" ) |
29ae6919 |
272 | or BAIL_OUT("$class does not have a meta() method (did you forget to 'use Moose'?)"); |
ddd87d75 |
273 | } |
274 | |
275 | sub check_isa { |
276 | my $class = shift; |
277 | my $parents = shift; |
278 | |
279 | my @isa = $class->meta->linearized_isa; |
280 | shift @isa; # returns $class as the first entry |
281 | |
282 | my $count = scalar @{$parents}; |
283 | my $noun = PL_N( 'parent', $count ); |
284 | |
285 | is( scalar @isa, $count, "$class has $count $noun" ); |
286 | |
287 | for ( my $i = 0; $i < @{$parents}; $i++ ) { |
288 | is( $isa[$i], $parents->[$i], "parent[$i] is $parents->[$i]" ); |
289 | } |
290 | } |
291 | |
ddd87d75 |
292 | sub has_rw_attr { |
605c1144 |
293 | my $class = shift; |
294 | my $name = shift; |
295 | my $overridden = shift; |
ddd87d75 |
296 | |
605c1144 |
297 | my $articled = $overridden ? "an overridden $name" : A($name); |
5cab7e05 |
298 | ok( $class->meta->has_attribute($name), |
8d1ce1d7 |
299 | "$class has $articled attribute" ); |
ddd87d75 |
300 | |
301 | my $attr = $class->meta->get_attribute($name); |
302 | |
8d1ce1d7 |
303 | is( $attr->get_read_method, $name, |
304 | "$name attribute has a reader accessor - $name()" ); |
305 | is( $attr->get_write_method, $name, |
306 | "$name attribute has a writer accessor - $name()" ); |
ddd87d75 |
307 | } |
308 | |
309 | sub has_ro_attr { |
310 | my $class = shift; |
311 | my $name = shift; |
312 | |
8d1ce1d7 |
313 | my $articled = A($name); |
5cab7e05 |
314 | ok( $class->meta->has_attribute($name), |
8d1ce1d7 |
315 | "$class has $articled attribute" ); |
ddd87d75 |
316 | |
317 | my $attr = $class->meta->get_attribute($name); |
318 | |
8d1ce1d7 |
319 | is( $attr->get_read_method, $name, |
320 | "$name attribute has a reader accessor - $name()" ); |
321 | is( $attr->get_write_method, undef, |
322 | "$name attribute does not have a writer" ); |
ddd87d75 |
323 | } |
324 | |
325 | sub has_method { |
326 | my $class = shift; |
327 | my $name = shift; |
328 | |
8d1ce1d7 |
329 | my $articled = A($name); |
330 | ok( $class->meta->has_method($name), "$class has $articled method" ); |
ddd87d75 |
331 | } |
332 | |
333 | sub has_overridden_method { |
334 | my $class = shift; |
335 | my $name = shift; |
336 | |
8d1ce1d7 |
337 | my $articled = A($name); |
338 | ok( $class->meta->has_method($name), "$class has $articled method" ); |
ddd87d75 |
339 | |
340 | my $meth = $class->meta->get_method($name); |
341 | isa_ok( $meth, 'Moose::Meta::Method::Overridden' ); |
342 | } |
343 | |
538499df |
344 | sub has_augmented_method { |
345 | my $class = shift; |
346 | my $name = shift; |
347 | |
348 | my $articled = A($name); |
349 | ok( $class->meta->has_method($name), "$class has $articled method" ); |
350 | |
351 | my $meth = $class->meta->get_method($name); |
352 | isa_ok( $meth, 'Moose::Meta::Method::Augmented' ); |
353 | } |
354 | |
ddd87d75 |
355 | sub no_droppings { |
356 | my $class = shift; |
357 | |
358 | ok( !$class->can('has'), "no Moose droppings in $class" ); |
ad648c43 |
359 | ok( !$class->can('subtype'), "no Moose::Util::TypeConstraints droppings in $class" ); |
ddd87d75 |
360 | } |
361 | |
362 | sub is_immutable { |
363 | my $class = shift; |
364 | |
365 | ok( $class->meta->is_immutable, "$class has been made immutable" ); |
366 | } |
367 | |
5cab7e05 |
368 | sub does_role { |
369 | my $class = shift; |
370 | my $role = shift; |
371 | |
372 | ok( $class->meta->does_role($role), "$class does the $role role" ); |
373 | } |
374 | |
ddd87d75 |
375 | sub person01 { |
376 | my $person = Person->new( |
377 | first_name => 'Bilbo', |
378 | last_name => 'Baggins', |
379 | ); |
380 | |
8d1ce1d7 |
381 | is( $person->full_name, 'Bilbo Baggins', |
382 | 'full_name() is correctly implemented' ); |
f7da468c |
383 | |
d047d1d4 |
384 | $person = eval { Person->new( [ qw( Lisa Smith ) ] ) }; |
385 | ok( !$@, 'Person->new() can accept an array reference as an argument' ) |
386 | or BAIL_OUT( |
387 | 'You must implement Person->BUILDARGS in order to continue these tests' |
388 | ); |
389 | |
f7da468c |
390 | is( $person->first_name, 'Lisa', 'set first_name from two-arg arrayref' ); |
391 | is( $person->last_name, 'Smith', 'set last_name from two-arg arrayref' ); |
392 | |
393 | eval { Person->new( sub { 'foo' } ) }; |
394 | like( $@, qr/\QSingle parameters to new() must be a HASH ref/, |
395 | 'Person constructor still rejects bad parameters' ); |
ddd87d75 |
396 | } |
397 | |
398 | sub employee01 { |
399 | my $employee = Employee->new( |
400 | first_name => 'Amanda', |
401 | last_name => 'Palmer', |
8d1ce1d7 |
402 | title => 'Singer', |
ddd87d75 |
403 | ); |
404 | |
54b470f5 |
405 | my $called = 0; |
406 | my $orig_super = \&Employee::super; |
407 | no warnings 'redefine'; |
408 | local *Employee::super = sub { $called++; goto &$orig_super }; |
409 | |
f555d2ec |
410 | is( $employee->full_name, 'Amanda Palmer (Singer)', |
411 | 'full_name() is properly overriden in Employee' ); |
54b470f5 |
412 | ok( $called, 'Employee->full_name calls super()' ); |
ddd87d75 |
413 | } |
414 | |
5cab7e05 |
415 | sub person02 { |
416 | my $person = Person->new( |
417 | first_name => 'Bilbo', |
418 | last_name => 'Baggins', |
419 | balance => 0, |
420 | ); |
421 | |
8d1ce1d7 |
422 | is( $person->as_string, 'Bilbo Baggins', |
423 | 'as_string() is correctly implemented' ); |
5cab7e05 |
424 | |
425 | account_tests($person); |
426 | } |
427 | |
428 | sub employee02 { |
429 | my $employee = Employee->new( |
430 | first_name => 'Amanda', |
431 | last_name => 'Palmer', |
8d1ce1d7 |
432 | title => 'Singer', |
5cab7e05 |
433 | balance => 0, |
434 | ); |
435 | |
8d1ce1d7 |
436 | is( $employee->as_string, 'Amanda Palmer (Singer)', |
437 | 'as_string() uses overridden full_name method in Employee' ); |
5cab7e05 |
438 | |
439 | account_tests($employee); |
440 | } |
441 | |
8d1ce1d7 |
442 | sub person03 { |
443 | my $person = Person->new( |
444 | first_name => 'Bilbo', |
445 | last_name => 'Baggins', |
446 | ); |
447 | |
448 | is( $person->full_name, 'Bilbo Baggins', |
449 | 'full_name() is correctly implemented for a Person without a title' ); |
450 | ok( !$person->has_title, |
3647da1b |
451 | 'Person has_title predicate is working correctly (returns false)' ); |
8d1ce1d7 |
452 | |
453 | $person->title('Ringbearer'); |
3647da1b |
454 | ok( $person->has_title, 'Person has_title predicate is working correctly (returns true)' ); |
455 | |
3647da1b |
456 | my $called = 0; |
54b470f5 |
457 | my $orig_pred = \&Person::has_title; |
458 | no warnings 'redefine'; |
459 | local *Person::has_title = sub { $called++; goto &$orig_pred }; |
460 | |
8d1ce1d7 |
461 | is( $person->full_name, 'Bilbo Baggins (Ringbearer)', |
462 | 'full_name() is correctly implemented for a Person with a title' ); |
3647da1b |
463 | ok( $called, 'full_name in person uses the predicate for the title attribute' ); |
8d1ce1d7 |
464 | |
465 | $person->clear_title; |
466 | ok( !$person->has_title, 'Person clear_title method cleared the title' ); |
467 | |
468 | account_tests( $person, 100 ); |
469 | } |
470 | |
471 | sub employee03 { |
472 | my $employee = Employee->new( |
473 | first_name => 'Jimmy', |
474 | last_name => 'Foo', |
475 | salary_level => 3, |
476 | salary => 42, |
477 | ); |
478 | |
479 | is( $employee->salary, 30000, |
480 | 'salary is calculated from salary_level, and salary passed to constructor is ignored' ); |
481 | } |
482 | |
66b226e5 |
483 | sub person06 { |
484 | my $person = Person->new( |
485 | first_name => 'Bilbo', |
486 | last_name => 'Baggins', |
487 | ); |
488 | |
489 | isa_ok( $person->account, 'BankAccount' ); |
490 | is( $person->account->owner, $person, |
491 | 'owner of bank account is person that created account' ); |
492 | |
493 | $person->deposit(10); |
648519ab |
494 | is_deeply( $person->account->history, [ 100 ], |
66b226e5 |
495 | 'deposit was recorded in account history' ); |
496 | |
497 | $person->withdraw(15); |
648519ab |
498 | is_deeply( $person->account->history, [ 100, 110 ], |
499 | 'withdrawal was recorded in account history' ); |
500 | |
501 | $person->withdraw(45); |
502 | is_deeply( $person->account->history, [ 100, 110, 95 ], |
66b226e5 |
503 | 'withdrawal was recorded in account history' ); |
504 | } |
505 | |
5cab7e05 |
506 | sub account_tests { |
507 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
508 | |
509 | my $person = shift; |
8d1ce1d7 |
510 | my $base_amount = shift || 0; |
5cab7e05 |
511 | |
512 | $person->deposit(50); |
8d1ce1d7 |
513 | eval { $person->withdraw( 75 + $base_amount ) }; |
514 | like( $@, qr/\QBalance cannot be negative/, |
515 | 'cannot withdraw more than is in our balance' ); |
5cab7e05 |
516 | |
8d1ce1d7 |
517 | $person->withdraw( 23 ); |
5cab7e05 |
518 | |
8d1ce1d7 |
519 | is( $person->balance, 27 + $base_amount, |
520 | 'balance is 27 (+ starting balance) after deposit of 50 and withdrawal of 23' ); |
5cab7e05 |
521 | } |
ddd87d75 |
522 | |
523 | 1; |