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