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 { |
ddd87d75 |
10 | has_meta('Person'); |
11 | |
12 | check_isa( 'Person', ['Moose::Object'] ); |
13 | |
ddd87d75 |
14 | has_rw_attr( 'Person', $_ ) for qw( first_name last_name ); |
15 | |
16 | has_method( 'Person', 'full_name' ); |
17 | |
ddd87d75 |
18 | person01(); |
19 | |
20 | has_meta('Employee'); |
21 | |
22 | check_isa( 'Employee', [ 'Person', 'Moose::Object' ] ); |
23 | |
8d1ce1d7 |
24 | has_rw_attr( 'Employee', $_ ) for qw( title salary ); |
ddd87d75 |
25 | has_ro_attr( 'Employee', 'ssn' ); |
26 | |
27 | has_overridden_method( 'Employee', 'full_name' ); |
28 | |
29 | employee01(); |
b071f963 |
30 | |
31 | no_droppings('Person'); |
32 | is_immutable('Person'); |
8d4c9dbf |
33 | |
34 | no_droppings('Employee'); |
35 | is_immutable('Employee'); |
ddd87d75 |
36 | } |
37 | |
5cab7e05 |
38 | sub tests02 { |
70eec86e |
39 | has_meta('Printable'); |
40 | requires_method( 'Printable', 'as_string' ); |
41 | |
42 | has_meta('Person'); |
43 | does_role( 'Person', 'Printable' ); |
44 | has_method( 'Person', 'as_string' ); |
5cab7e05 |
45 | |
70eec86e |
46 | has_meta('HasAccount'); |
47 | has_method( 'HasAccount', $_ ) for qw( deposit withdraw ); |
48 | has_role_attr( 'HasAccount', 'balance' ); |
49 | |
50 | does_role( 'Person', 'HasAccount' ); |
51 | has_method( 'Person', $_ ) for qw( deposit withdraw ); |
5cab7e05 |
52 | has_rw_attr( 'Person', 'balance' ); |
53 | |
70eec86e |
54 | has_meta('Employee'); |
5cab7e05 |
55 | does_role( 'Employee', $_ ) for qw( Printable HasAccount ); |
56 | |
57 | person02(); |
58 | employee02(); |
70eec86e |
59 | |
60 | no_droppings($_) for qw( Printable HasAccount ); |
61 | |
62 | tests01(); |
5cab7e05 |
63 | } |
64 | |
8d1ce1d7 |
65 | sub tests03 { |
00c47fc4 |
66 | has_meta('Person'); |
8d1ce1d7 |
67 | |
39182c07 |
68 | for my $name ( qw( first_name last_name ) ) { |
69 | has_rw_attr( 'Person', $name ); |
8d1ce1d7 |
70 | |
39182c07 |
71 | my $attr = Person->meta->get_attribute($name); |
72 | ok( $attr && $attr->is_required, |
73 | "$name is required in Person" ); |
74 | } |
8d1ce1d7 |
75 | |
39182c07 |
76 | has_rw_attr( 'Person', 'title' ); |
8d1ce1d7 |
77 | |
78 | my $person_title_attr = Person->meta->get_attribute('title'); |
79 | ok( !$person_title_attr->is_required, 'title is not required in Person' ); |
70eec86e |
80 | is( |
81 | $person_title_attr->predicate, 'has_title', |
82 | 'Person title attr has a has_title predicate' |
83 | ); |
84 | is( |
85 | $person_title_attr->clearer, 'clear_title', |
86 | 'Person title attr has a clear_title clearer' |
87 | ); |
8d1ce1d7 |
88 | |
39182c07 |
89 | person03(); |
90 | |
91 | has_meta('Employee'); |
92 | |
93 | has_rw_attr( 'Employee', 'title', 'overridden' ); |
8d1ce1d7 |
94 | |
95 | my $employee_title_attr = Employee->meta->get_attribute('title'); |
70eec86e |
96 | is( |
97 | $employee_title_attr->default, 'Worker', |
98 | 'title defaults to Worker in Employee' |
99 | ); |
8d1ce1d7 |
100 | |
39182c07 |
101 | ok( |
102 | !Employee->meta->has_method('full_name'), |
103 | 'Employee no longer implements a full_name method' |
104 | ); |
105 | |
106 | has_ro_attr( 'Employee', 'salary' ); |
8d1ce1d7 |
107 | |
108 | my $salary_attr = Employee->meta->get_attribute('salary'); |
39182c07 |
109 | ok( $salary_attr->is_lazy, 'salary is lazy' ); |
8d1ce1d7 |
110 | ok( !$salary_attr->init_arg, 'no init_arg for salary attribute' ); |
111 | ok( $salary_attr->has_builder, 'salary attr has a builder' ); |
112 | |
39182c07 |
113 | has_method( 'Employee', '_build_salary' ); |
114 | |
115 | has_rw_attr( 'Employee', 'salary_level' ); |
116 | |
117 | my $salary_level_attr = Employee->meta->get_attribute('salary_level'); |
118 | is( $salary_level_attr->default, 1, 'salary_level defaults to 1' ); |
119 | |
8d1ce1d7 |
120 | employee03(); |
39182c07 |
121 | |
122 | my $balance_attr = Person->meta->get_attribute('balance'); |
123 | is( $balance_attr->default, 100, 'balance defaults to 100' ); |
8d1ce1d7 |
124 | } |
125 | |
26164c8d |
126 | sub tests04 { |
c21bbce8 |
127 | has_meta('Person'); |
128 | |
129 | ok( Person->can('full_name'), 'Person has a full_name() method' ) |
130 | or BAIL_OUT( |
131 | 'Person does not have a full_name() method. Cannot continue testing.' |
132 | ); |
133 | |
134 | my $meth = Person->meta()->get_method('full_name'); |
135 | ok( |
136 | $meth && $meth->isa('Class::MOP::Method::Wrapped'), |
137 | 'method modifiers have been applied to the Person->full_name method' |
138 | ); |
139 | |
140 | is( |
141 | scalar $meth->before_modifiers, |
142 | 1, |
143 | 'Person->full_name has a single before modifier' |
144 | ); |
145 | |
146 | is( |
147 | scalar $meth->after_modifiers, |
148 | 1, |
149 | 'Person->full_name has a single after modifier' |
150 | ); |
151 | |
152 | my $person = Person->new( |
153 | first_name => 'Bilbo', |
154 | last_name => 'Baggins', |
538499df |
155 | ); |
26164c8d |
156 | |
c21bbce8 |
157 | is_deeply( |
158 | \@Person::CALL, |
159 | [], |
160 | 'Person::CALL global is empty before calling full_name' |
161 | ); |
162 | |
163 | $person->full_name(); |
164 | |
165 | is_deeply( |
166 | \@Person::CALL, |
167 | [ 'calling full_name', 'called full_name' ], |
168 | 'Person::CALL global contains before and after strings' |
169 | ); |
170 | |
171 | is( |
172 | scalar $meth->around_modifiers, |
173 | 1, |
174 | 'Person->full_name has a single around modifier' |
175 | ); |
176 | |
177 | my $larry = Person->new( |
178 | first_name => 'Larry', |
179 | last_name => 'Wall', |
180 | ); |
181 | |
182 | is( |
183 | $larry->full_name, |
184 | '*Larry Wall*', |
185 | 'full_name is wrapped by asterisks when last name is Wall' |
186 | ); |
26164c8d |
187 | } |
188 | |
ad648c43 |
189 | sub tests05 { |
00c47fc4 |
190 | has_meta('Person'); |
ad648c43 |
191 | |
70eec86e |
192 | for my $attr_name (qw( first_name last_name title )) { |
ad648c43 |
193 | my $attr = Person->meta->get_attribute($attr_name); |
194 | |
70eec86e |
195 | ok( |
196 | $attr->has_type_constraint, |
197 | "Person $attr_name has a type constraint" |
198 | ); |
199 | is( |
200 | $attr->type_constraint->name, 'Str', |
201 | "Person $attr_name type is Str" |
202 | ); |
ad648c43 |
203 | } |
204 | |
21c6ab1c |
205 | has_meta('Employee'); |
206 | |
ad648c43 |
207 | { |
208 | my $salary_level_attr = Employee->meta->get_attribute('salary_level'); |
70eec86e |
209 | ok( |
210 | $salary_level_attr->has_type_constraint, |
211 | 'Employee salary_level has a type constraint' |
212 | ); |
ad648c43 |
213 | |
214 | my $tc = $salary_level_attr->type_constraint; |
215 | |
216 | for my $invalid ( 0, 11, -14, 'foo', undef ) { |
217 | my $str = defined $invalid ? $invalid : 'undef'; |
70eec86e |
218 | ok( |
219 | !$tc->check($invalid), |
220 | "salary_level type rejects invalid value - $str" |
221 | ); |
ad648c43 |
222 | } |
223 | |
70eec86e |
224 | for my $valid ( 1 .. 10 ) { |
225 | ok( |
226 | $tc->check($valid), |
227 | "salary_level type accepts valid value - $valid" |
228 | ); |
ad648c43 |
229 | } |
230 | } |
231 | |
232 | { |
233 | my $salary_attr = Employee->meta->get_attribute('salary'); |
234 | |
70eec86e |
235 | ok( |
236 | $salary_attr->has_type_constraint, |
237 | 'Employee salary has a type constraint' |
238 | ); |
ad648c43 |
239 | |
240 | my $tc = $salary_attr->type_constraint; |
241 | |
242 | for my $invalid ( 0, -14, 'foo', undef ) { |
243 | my $str = defined $invalid ? $invalid : 'undef'; |
70eec86e |
244 | ok( |
245 | !$tc->check($invalid), |
246 | "salary type rejects invalid value - $str" |
247 | ); |
ad648c43 |
248 | } |
249 | |
250 | for my $valid ( 1, 100_000, 10**10 ) { |
70eec86e |
251 | ok( |
252 | $tc->check($valid), |
253 | "salary type accepts valid value - $valid" |
254 | ); |
ad648c43 |
255 | } |
256 | } |
257 | |
258 | { |
259 | my $ssn_attr = Employee->meta->get_attribute('ssn'); |
260 | |
70eec86e |
261 | ok( |
262 | $ssn_attr->has_type_constraint, |
263 | 'Employee ssn has a type constraint' |
264 | ); |
ad648c43 |
265 | |
266 | my $tc = $ssn_attr->type_constraint; |
267 | |
268 | for my $invalid ( 0, -14, 'foo', undef, '123-ab-1241', '123456789' ) { |
269 | my $str = defined $invalid ? $invalid : 'undef'; |
70eec86e |
270 | ok( |
271 | !$tc->check($invalid), |
272 | "ssn type rejects invalid value - $str" |
273 | ); |
ad648c43 |
274 | } |
275 | |
276 | for my $valid ( '041-12-1251', '123-45-6789', '926-41-5820' ) { |
70eec86e |
277 | ok( |
278 | $tc->check($valid), |
279 | "ssn type accepts valid value - $valid" |
280 | ); |
ad648c43 |
281 | } |
282 | } |
21c6ab1c |
283 | |
284 | no_droppings('Employee'); |
ad648c43 |
285 | } |
286 | |
66b226e5 |
287 | sub tests06 { |
00c47fc4 |
288 | has_meta('BankAccount'); |
66b226e5 |
289 | |
5a6ef0a4 |
290 | has_rw_attr( 'BankAccount', $_ ) for qw( balance owner ); |
66b226e5 |
291 | |
36e1e336 |
292 | my $ba_meta = BankAccount->meta; |
5a6ef0a4 |
293 | |
70eec86e |
294 | ok( |
5a6ef0a4 |
295 | $ba_meta->get_attribute('owner')->is_weak_ref, |
296 | 'owner attribute is a weak ref' |
70eec86e |
297 | ); |
36e1e336 |
298 | |
5a6ef0a4 |
299 | has_method( 'BankAccount', $_ ) for qw( deposit withdraw ); |
300 | |
301 | has_ro_attr( 'BankAccount', 'history' ); |
302 | |
ed84c5c6 |
303 | my $history_attr = $ba_meta->get_attribute('history'); |
304 | |
5a6ef0a4 |
305 | is_deeply( |
306 | $history_attr->default->(), |
307 | [], |
308 | 'BankAccount history attribute defaults to []' |
309 | ); |
310 | |
311 | { |
312 | my $tc = $history_attr->type_constraint; |
313 | |
314 | for my $invalid ( 0, 42, undef, {}, [ 'foo', 'bar' ] ) { |
315 | my $str = defined $invalid ? $invalid : 'undef'; |
316 | ok( |
317 | !$tc->check($invalid), |
318 | "salary_level type rejects invalid value - $str" |
319 | ); |
320 | } |
321 | |
322 | for my $valid ( [], [1], [ 1, 2, 3 ], [ 1, -10, 9999 ] ) { |
323 | ok( |
324 | $tc->check($valid), |
325 | "salary_level type accepts valid value" |
326 | ); |
327 | } |
328 | } |
329 | |
ed84c5c6 |
330 | ok( |
4f7392e8 |
331 | $history_attr->meta()->can('does_role') |
332 | && $history_attr->meta() |
ed84c5c6 |
333 | ->does_role('Moose::Meta::Attribute::Native::Trait::Array'), |
334 | 'BankAccount history attribute uses native delegation to an array ref' |
335 | ); |
336 | |
70eec86e |
337 | ok( |
338 | $ba_meta->get_attribute('balance')->has_trigger, |
339 | 'BankAccount balance attribute has a trigger' |
340 | ); |
36e1e336 |
341 | |
5a6ef0a4 |
342 | has_meta('Person'); |
343 | |
66b226e5 |
344 | my $person_meta = Person->meta; |
5a6ef0a4 |
345 | |
346 | ok( !$person_meta->does_role('HasAccount'), |
347 | 'Person class does not do the HasAccount role' ); |
348 | |
70eec86e |
349 | ok( |
350 | !$person_meta->has_attribute('balance'), |
351 | 'Person class does not have a balance attribute' |
352 | ); |
66b226e5 |
353 | |
354 | my $deposit_meth = $person_meta->get_method('deposit'); |
355 | isa_ok( $deposit_meth, 'Moose::Meta::Method::Delegation' ); |
356 | |
357 | my $withdraw_meth = $person_meta->get_method('withdraw'); |
358 | isa_ok( $withdraw_meth, 'Moose::Meta::Method::Delegation' ); |
359 | |
66b226e5 |
360 | person06(); |
5a6ef0a4 |
361 | |
362 | has_meta('Employee'); |
363 | |
364 | no_droppings('BankAccount'); |
66b226e5 |
365 | } |
366 | |
ddd87d75 |
367 | sub has_meta { |
70eec86e |
368 | my $package = shift; |
ddd87d75 |
369 | |
00c47fc4 |
370 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
371 | |
cc4c7f3e |
372 | { |
373 | my @warn; |
374 | local $SIG{__WARN__} = sub { push @warn, @_ }; |
375 | |
376 | use_ok($package) |
377 | or BAIL_OUT("$package cannot be loaded"); |
378 | |
379 | BAIL_OUT("Warning when loading $package: @warn") |
380 | if @warn; |
381 | } |
5c7cd208 |
382 | |
70eec86e |
383 | ok( $package->can('meta'), "$package has a meta() method" ) |
384 | or BAIL_OUT( |
385 | "$package does not have a meta() method (did you forget to 'use Moose'?)" |
386 | ); |
ddd87d75 |
387 | } |
388 | |
389 | sub check_isa { |
390 | my $class = shift; |
391 | my $parents = shift; |
392 | |
00c47fc4 |
393 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
394 | |
ddd87d75 |
395 | my @isa = $class->meta->linearized_isa; |
396 | shift @isa; # returns $class as the first entry |
397 | |
398 | my $count = scalar @{$parents}; |
399 | my $noun = PL_N( 'parent', $count ); |
400 | |
401 | is( scalar @isa, $count, "$class has $count $noun" ); |
402 | |
403 | for ( my $i = 0; $i < @{$parents}; $i++ ) { |
404 | is( $isa[$i], $parents->[$i], "parent[$i] is $parents->[$i]" ); |
405 | } |
406 | } |
407 | |
ddd87d75 |
408 | sub has_rw_attr { |
605c1144 |
409 | my $class = shift; |
410 | my $name = shift; |
411 | my $overridden = shift; |
ddd87d75 |
412 | |
00c47fc4 |
413 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
414 | |
605c1144 |
415 | my $articled = $overridden ? "an overridden $name" : A($name); |
70eec86e |
416 | ok( |
417 | $class->meta->has_attribute($name), |
418 | "$class has $articled attribute" |
419 | ); |
ddd87d75 |
420 | |
421 | my $attr = $class->meta->get_attribute($name); |
422 | |
70eec86e |
423 | is( |
424 | $attr->get_read_method, $name, |
425 | "$name attribute has a reader accessor - $name()" |
426 | ); |
427 | is( |
428 | $attr->get_write_method, $name, |
429 | "$name attribute has a writer accessor - $name()" |
430 | ); |
ddd87d75 |
431 | } |
432 | |
433 | sub has_ro_attr { |
434 | my $class = shift; |
435 | my $name = shift; |
436 | |
00c47fc4 |
437 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
438 | |
8d1ce1d7 |
439 | my $articled = A($name); |
70eec86e |
440 | ok( |
441 | $class->meta->has_attribute($name), |
442 | "$class has $articled attribute" |
443 | ); |
ddd87d75 |
444 | |
445 | my $attr = $class->meta->get_attribute($name); |
446 | |
70eec86e |
447 | is( |
448 | $attr->get_read_method, $name, |
449 | "$name attribute has a reader accessor - $name()" |
450 | ); |
451 | is( |
452 | $attr->get_write_method, undef, |
453 | "$name attribute does not have a writer" |
454 | ); |
455 | } |
456 | |
457 | sub has_role_attr { |
458 | my $role = shift; |
459 | my $name = shift; |
460 | |
00c47fc4 |
461 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
462 | |
70eec86e |
463 | my $articled = A($name); |
464 | ok( |
465 | $role->meta->get_attribute($name), |
466 | "$role has $articled attribute" |
467 | ); |
ddd87d75 |
468 | } |
469 | |
470 | sub has_method { |
70eec86e |
471 | my $package = shift; |
472 | my $name = shift; |
ddd87d75 |
473 | |
00c47fc4 |
474 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
475 | |
8d1ce1d7 |
476 | my $articled = A($name); |
70eec86e |
477 | ok( $package->meta->has_method($name), "$package has $articled method" ); |
ddd87d75 |
478 | } |
479 | |
480 | sub has_overridden_method { |
70eec86e |
481 | my $package = shift; |
482 | my $name = shift; |
ddd87d75 |
483 | |
00c47fc4 |
484 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
485 | |
8d1ce1d7 |
486 | my $articled = A($name); |
70eec86e |
487 | ok( $package->meta->has_method($name), "$package has $articled method" ); |
ddd87d75 |
488 | |
70eec86e |
489 | my $meth = $package->meta->get_method($name); |
ddd87d75 |
490 | isa_ok( $meth, 'Moose::Meta::Method::Overridden' ); |
491 | } |
492 | |
538499df |
493 | sub has_augmented_method { |
494 | my $class = shift; |
495 | my $name = shift; |
496 | |
00c47fc4 |
497 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
498 | |
538499df |
499 | my $articled = A($name); |
500 | ok( $class->meta->has_method($name), "$class has $articled method" ); |
501 | |
502 | my $meth = $class->meta->get_method($name); |
503 | isa_ok( $meth, 'Moose::Meta::Method::Augmented' ); |
504 | } |
505 | |
70eec86e |
506 | sub requires_method { |
507 | my $package = shift; |
508 | my $method = shift; |
509 | |
00c47fc4 |
510 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
511 | |
70eec86e |
512 | ok( |
513 | $package->meta->requires_method($method), |
514 | "$package requires the method $method" |
515 | ); |
516 | } |
517 | |
ddd87d75 |
518 | sub no_droppings { |
70eec86e |
519 | my $package = shift; |
ddd87d75 |
520 | |
00c47fc4 |
521 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
522 | |
70eec86e |
523 | ok( !$package->can('has'), "no Moose droppings in $package" ); |
524 | ok( !$package->can('subtype'), |
525 | "no Moose::Util::TypeConstraints droppings in $package" ); |
ddd87d75 |
526 | } |
527 | |
528 | sub is_immutable { |
529 | my $class = shift; |
530 | |
00c47fc4 |
531 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
532 | |
ddd87d75 |
533 | ok( $class->meta->is_immutable, "$class has been made immutable" ); |
534 | } |
535 | |
5cab7e05 |
536 | sub does_role { |
70eec86e |
537 | my $package = shift; |
538 | my $role = shift; |
5cab7e05 |
539 | |
00c47fc4 |
540 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
541 | |
70eec86e |
542 | ok( $package->meta->does_role($role), "$package does the $role role" ); |
5cab7e05 |
543 | } |
544 | |
ddd87d75 |
545 | sub person01 { |
546 | my $person = Person->new( |
547 | first_name => 'Bilbo', |
548 | last_name => 'Baggins', |
549 | ); |
550 | |
70eec86e |
551 | is( |
552 | $person->full_name, 'Bilbo Baggins', |
553 | 'full_name() is correctly implemented' |
554 | ); |
f7da468c |
555 | |
d047d1d4 |
556 | $person = eval { Person->new( [ qw( Lisa Smith ) ] ) }; |
eb959c49 |
557 | |
558 | if ( my $e = $@ ) { |
559 | diag( |
560 | "Calling Person->new() with an array reference threw an error:\n$e" |
561 | ); |
562 | BAIL_OUT( |
563 | 'You must implement Person->BUILDARGS correctly in order to continue these tests' |
d047d1d4 |
564 | ); |
eb959c49 |
565 | } |
566 | else { |
567 | ok( 1, 'Person->new() can accept an array reference as an argument' ); |
568 | } |
d047d1d4 |
569 | |
f7da468c |
570 | is( $person->first_name, 'Lisa', 'set first_name from two-arg arrayref' ); |
571 | is( $person->last_name, 'Smith', 'set last_name from two-arg arrayref' ); |
572 | |
70eec86e |
573 | eval { |
574 | Person->new( sub {'foo'} ); |
575 | }; |
576 | like( |
577 | $@, qr/\QSingle parameters to new() must be a HASH ref/, |
578 | 'Person constructor still rejects bad parameters' |
579 | ); |
ddd87d75 |
580 | } |
581 | |
582 | sub employee01 { |
583 | my $employee = Employee->new( |
584 | first_name => 'Amanda', |
585 | last_name => 'Palmer', |
8d1ce1d7 |
586 | title => 'Singer', |
ddd87d75 |
587 | ); |
588 | |
70eec86e |
589 | my $called = 0; |
54b470f5 |
590 | my $orig_super = \&Employee::super; |
591 | no warnings 'redefine'; |
592 | local *Employee::super = sub { $called++; goto &$orig_super }; |
593 | |
70eec86e |
594 | is( |
595 | $employee->full_name, 'Amanda Palmer (Singer)', |
596 | 'full_name() is properly overriden in Employee' |
597 | ); |
54b470f5 |
598 | ok( $called, 'Employee->full_name calls super()' ); |
ddd87d75 |
599 | } |
600 | |
5cab7e05 |
601 | sub person02 { |
602 | my $person = Person->new( |
603 | first_name => 'Bilbo', |
604 | last_name => 'Baggins', |
605 | balance => 0, |
606 | ); |
607 | |
70eec86e |
608 | is( |
609 | $person->as_string, 'Bilbo Baggins', |
610 | 'as_string() is correctly implemented' |
611 | ); |
5cab7e05 |
612 | |
613 | account_tests($person); |
614 | } |
615 | |
616 | sub employee02 { |
617 | my $employee = Employee->new( |
618 | first_name => 'Amanda', |
619 | last_name => 'Palmer', |
8d1ce1d7 |
620 | title => 'Singer', |
5cab7e05 |
621 | balance => 0, |
622 | ); |
623 | |
70eec86e |
624 | is( |
625 | $employee->as_string, 'Amanda Palmer (Singer)', |
626 | 'as_string() uses overridden full_name method in Employee' |
627 | ); |
5cab7e05 |
628 | |
629 | account_tests($employee); |
630 | } |
631 | |
8d1ce1d7 |
632 | sub person03 { |
633 | my $person = Person->new( |
634 | first_name => 'Bilbo', |
635 | last_name => 'Baggins', |
636 | ); |
637 | |
70eec86e |
638 | is( |
639 | $person->full_name, 'Bilbo Baggins', |
640 | 'full_name() is correctly implemented for a Person without a title' |
641 | ); |
642 | ok( |
643 | !$person->has_title, |
644 | 'Person has_title predicate is working correctly (returns false)' |
645 | ); |
8d1ce1d7 |
646 | |
647 | $person->title('Ringbearer'); |
70eec86e |
648 | ok( $person->has_title, |
649 | 'Person has_title predicate is working correctly (returns true)' ); |
3647da1b |
650 | |
70eec86e |
651 | my $called = 0; |
54b470f5 |
652 | my $orig_pred = \&Person::has_title; |
653 | no warnings 'redefine'; |
654 | local *Person::has_title = sub { $called++; goto &$orig_pred }; |
655 | |
70eec86e |
656 | is( |
657 | $person->full_name, 'Bilbo Baggins (Ringbearer)', |
658 | 'full_name() is correctly implemented for a Person with a title' |
659 | ); |
660 | ok( $called, |
661 | 'full_name in person uses the predicate for the title attribute' ); |
8d1ce1d7 |
662 | |
663 | $person->clear_title; |
664 | ok( !$person->has_title, 'Person clear_title method cleared the title' ); |
665 | |
666 | account_tests( $person, 100 ); |
667 | } |
668 | |
669 | sub employee03 { |
670 | my $employee = Employee->new( |
671 | first_name => 'Jimmy', |
672 | last_name => 'Foo', |
673 | salary_level => 3, |
674 | salary => 42, |
675 | ); |
676 | |
70eec86e |
677 | is( |
678 | $employee->salary, 30000, |
679 | 'salary is calculated from salary_level, and salary passed to constructor is ignored' |
680 | ); |
8d1ce1d7 |
681 | } |
682 | |
66b226e5 |
683 | sub person06 { |
0235f94b |
684 | my $account = BankAccount->new(); |
685 | |
66b226e5 |
686 | my $person = Person->new( |
687 | first_name => 'Bilbo', |
688 | last_name => 'Baggins', |
0235f94b |
689 | account => $account, |
690 | ); |
691 | |
692 | is( |
693 | $person->account, $account, |
694 | 'account object passed to Person->new is still in object' |
66b226e5 |
695 | ); |
696 | |
697 | isa_ok( $person->account, 'BankAccount' ); |
70eec86e |
698 | is( |
699 | $person->account->owner, $person, |
700 | 'owner of bank account is person that created account' |
701 | ); |
66b226e5 |
702 | |
703 | $person->deposit(10); |
70eec86e |
704 | is_deeply( |
705 | $person->account->history, [100], |
706 | 'deposit was recorded in account history' |
707 | ); |
66b226e5 |
708 | |
709 | $person->withdraw(15); |
70eec86e |
710 | is_deeply( |
711 | $person->account->history, [ 100, 110 ], |
712 | 'withdrawal was recorded in account history' |
713 | ); |
648519ab |
714 | |
715 | $person->withdraw(45); |
70eec86e |
716 | is_deeply( |
717 | $person->account->history, [ 100, 110, 95 ], |
718 | 'withdrawal was recorded in account history' |
719 | ); |
66b226e5 |
720 | } |
721 | |
5cab7e05 |
722 | sub account_tests { |
723 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
724 | |
725 | my $person = shift; |
8d1ce1d7 |
726 | my $base_amount = shift || 0; |
5cab7e05 |
727 | |
728 | $person->deposit(50); |
507d2b5f |
729 | |
730 | is( |
731 | $person->balance, 50 + $base_amount, |
732 | "balance is 50 + $base_amount", |
733 | ); |
734 | |
8d1ce1d7 |
735 | eval { $person->withdraw( 75 + $base_amount ) }; |
70eec86e |
736 | like( |
737 | $@, qr/\QBalance cannot be negative/, |
738 | 'cannot withdraw more than is in our balance' |
739 | ); |
5cab7e05 |
740 | |
70eec86e |
741 | $person->withdraw(23); |
5cab7e05 |
742 | |
70eec86e |
743 | is( |
744 | $person->balance, 27 + $base_amount, |
745 | 'balance is 27 (+ starting balance) after deposit of 50 and withdrawal of 23' |
746 | ); |
5cab7e05 |
747 | } |
ddd87d75 |
748 | |
749 | 1; |