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