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