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