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     no_droppings('Employee');
  35     is_immutable('Employee');
  36 }
  37
  38 sub tests02 {
  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' );
  45
  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 );
  52     has_rw_attr( 'Person', 'balance' );
  53
  54     has_meta('Employee');
  55     does_role( 'Employee', $_ ) for qw( Printable HasAccount );
  56
  57     person02();
  58     employee02();
  59
  60     no_droppings($_) for qw( Printable HasAccount );
  61
  62     tests01();
  63 }
  64
  65 sub tests03 {
  66     has_meta('Person');
  67
  68     for my $name ( qw( first_name last_name ) ) {
  69         has_rw_attr( 'Person', $name );
  70
  71         my $attr = Person->meta->get_attribute($name);
  72         ok( $attr && $attr->is_required,
  73             "$name is required in Person" );
  74     }
  75
  76     has_rw_attr( 'Person', 'title' );
  77
  78     my $person_title_attr = Person->meta->get_attribute('title');
  79     ok( !$person_title_attr->is_required, 'title is not required in Person' );
  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     );
  88
  89     person03();
  90
  91     has_meta('Employee');
  92
  93     has_rw_attr( 'Employee', 'title', 'overridden' );
  94
  95     my $employee_title_attr = Employee->meta->get_attribute('title');
  96     is(
  97         $employee_title_attr->default, 'Worker',
  98         'title defaults to Worker in Employee'
  99     );
 100
 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' );
 107
 108     my $salary_attr = Employee->meta->get_attribute('salary');
 109     ok( $salary_attr->is_lazy, 'salary is lazy' );
 110     ok( !$salary_attr->init_arg,   'no init_arg for salary attribute' );
 111     ok( $salary_attr->has_builder, 'salary attr has a builder' );
 112
 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
 120     employee03();
 121
 122     my $balance_attr = Person->meta->get_attribute('balance');
 123     is( $balance_attr->default, 100, 'balance defaults to 100' );
 124 }
 125
 126 sub tests04 {
 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',
 155     );
 156
 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     );
 187 }
 188
 189 sub tests05 {
 190     has_meta('Person');
 191
 192     for my $attr_name (qw( first_name last_name title )) {
 193         my $attr = Person->meta->get_attribute($attr_name);
 194
 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         );
 203     }
 204
 205     has_meta('Employee');
 206
 207     {
 208         my $salary_level_attr = Employee->meta->get_attribute('salary_level');
 209         ok(
 210             $salary_level_attr->has_type_constraint,
 211             'Employee salary_level has a type constraint'
 212         );
 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';
 218             ok(
 219                 !$tc->check($invalid),
 220                 "salary_level type rejects invalid value - $str"
 221             );
 222         }
 223
 224         for my $valid ( 1 .. 10 ) {
 225             ok(
 226                 $tc->check($valid),
 227                 "salary_level type accepts valid value - $valid"
 228             );
 229         }
 230     }
 231
 232     {
 233         my $salary_attr = Employee->meta->get_attribute('salary');
 234
 235         ok(
 236             $salary_attr->has_type_constraint,
 237             'Employee salary has a type constraint'
 238         );
 239
 240         my $tc = $salary_attr->type_constraint;
 241
 242         for my $invalid ( 0, -14, 'foo', undef ) {
 243             my $str = defined $invalid ? $invalid : 'undef';
 244             ok(
 245                 !$tc->check($invalid),
 246                 "salary type rejects invalid value - $str"
 247             );
 248         }
 249
 250         for my $valid ( 1, 100_000, 10**10 ) {
 251             ok(
 252                 $tc->check($valid),
 253                 "salary type accepts valid value - $valid"
 254             );
 255         }
 256     }
 257
 258     {
 259         my $ssn_attr = Employee->meta->get_attribute('ssn');
 260
 261         ok(
 262             $ssn_attr->has_type_constraint,
 263             'Employee ssn has a type constraint'
 264         );
 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';
 270             ok(
 271                 !$tc->check($invalid),
 272                 "ssn type rejects invalid value - $str"
 273             );
 274         }
 275
 276         for my $valid ( '041-12-1251', '123-45-6789', '926-41-5820' ) {
 277             ok(
 278                 $tc->check($valid),
 279                 "ssn type accepts valid value - $valid"
 280             );
 281         }
 282     }
 283
 284     no_droppings('Employee');
 285 }
 286
 287 sub tests06 {
 288     has_meta('BankAccount');
 289
 290     has_rw_attr( 'BankAccount', $_ ) for qw( balance owner );
 291
 292     my $ba_meta = BankAccount->meta;
 293
 294     ok(
 295         $ba_meta->get_attribute('owner')->is_weak_ref,
 296         'owner attribute is a weak ref'
 297     );
 298
 299     has_method( 'BankAccount', $_ ) for qw( deposit withdraw );
 300
 301     has_ro_attr( 'BankAccount', 'history' );
 302
 303     my $history_attr = $ba_meta->get_attribute('history');
 304
 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
 330     ok(
 331         $history_attr->meta()->can('does_role')
 332             && $history_attr->meta()
 333             ->does_role('Moose::Meta::Attribute::Native::Trait::Array'),
 334         'BankAccount history attribute uses native delegation to an array ref'
 335     );
 336
 337     ok(
 338         $ba_meta->get_attribute('balance')->has_trigger,
 339         'BankAccount balance attribute has a trigger'
 340     );
 341
 342     has_meta('Person');
 343
 344     my $person_meta = Person->meta;
 345
 346     ok( !$person_meta->does_role('HasAccount'),
 347         'Person class does not do the HasAccount role' );
 348
 349     ok(
 350         !$person_meta->has_attribute('balance'),
 351         'Person class does not have a balance attribute'
 352     );
 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
 360     person06();
 361
 362     has_meta('Employee');
 363
 364     no_droppings('BankAccount');
 365 }
 366
 367 sub has_meta {
 368     my $package = shift;
 369
 370     local $Test::Builder::Level = $Test::Builder::Level + 1;
 371
 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     }
 382
 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         );
 387 }
 388
 389 sub check_isa {
 390     my $class   = shift;
 391     my $parents = shift;
 392
 393     local $Test::Builder::Level = $Test::Builder::Level + 1;
 394
 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
 408 sub has_rw_attr {
 409     my $class      = shift;
 410     my $name       = shift;
 411     my $overridden = shift;
 412
 413     local $Test::Builder::Level = $Test::Builder::Level + 1;
 414
 415     my $articled = $overridden ? "an overridden $name" : A($name);
 416     ok(
 417         $class->meta->has_attribute($name),
 418         "$class has $articled attribute"
 419     );
 420
 421     my $attr = $class->meta->get_attribute($name);
 422
 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     );
 431 }
 432
 433 sub has_ro_attr {
 434     my $class = shift;
 435     my $name  = shift;
 436
 437     local $Test::Builder::Level = $Test::Builder::Level + 1;
 438
 439     my $articled = A($name);
 440     ok(
 441         $class->meta->has_attribute($name),
 442         "$class has $articled attribute"
 443     );
 444
 445     my $attr = $class->meta->get_attribute($name);
 446
 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
 461     local $Test::Builder::Level = $Test::Builder::Level + 1;
 462
 463     my $articled = A($name);
 464     ok(
 465         $role->meta->get_attribute($name),
 466         "$role has $articled attribute"
 467     );
 468 }
 469
 470 sub has_method {
 471     my $package = shift;
 472     my $name    = shift;
 473
 474     local $Test::Builder::Level = $Test::Builder::Level + 1;
 475
 476     my $articled = A($name);
 477     ok( $package->meta->has_method($name), "$package has $articled method" );
 478 }
 479
 480 sub has_overridden_method {
 481     my $package = shift;
 482     my $name    = shift;
 483
 484     local $Test::Builder::Level = $Test::Builder::Level + 1;
 485
 486     my $articled = A($name);
 487     ok( $package->meta->has_method($name), "$package has $articled method" );
 488
 489     my $meth = $package->meta->get_method($name);
 490     isa_ok( $meth, 'Moose::Meta::Method::Overridden' );
 491 }
 492
 493 sub has_augmented_method {
 494     my $class = shift;
 495     my $name  = shift;
 496
 497     local $Test::Builder::Level = $Test::Builder::Level + 1;
 498
 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
 506 sub requires_method {
 507     my $package = shift;
 508     my $method  = shift;
 509
 510     local $Test::Builder::Level = $Test::Builder::Level + 1;
 511
 512     ok(
 513         $package->meta->requires_method($method),
 514         "$package requires the method $method"
 515     );
 516 }
 517
 518 sub no_droppings {
 519     my $package = shift;
 520
 521     local $Test::Builder::Level = $Test::Builder::Level + 1;
 522
 523     ok( !$package->can('has'), "no Moose droppings in $package" );
 524     ok( !$package->can('subtype'),
 525         "no Moose::Util::TypeConstraints droppings in $package" );
 526 }
 527
 528 sub is_immutable {
 529     my $class = shift;
 530
 531     local $Test::Builder::Level = $Test::Builder::Level + 1;
 532
 533     ok( $class->meta->is_immutable, "$class has been made immutable" );
 534 }
 535
 536 sub does_role {
 537     my $package = shift;
 538     my $role    = shift;
 539
 540     local $Test::Builder::Level = $Test::Builder::Level + 1;
 541
 542     ok( $package->meta->does_role($role), "$package does the $role role" );
 543 }
 544
 545 sub person01 {
 546     my $person = Person->new(
 547         first_name => 'Bilbo',
 548         last_name  => 'Baggins',
 549     );
 550
 551     is(
 552         $person->full_name, 'Bilbo Baggins',
 553         'full_name() is correctly implemented'
 554     );
 555
 556     $person = eval { Person->new( [ qw( Lisa Smith ) ] ) };
 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'
 564         );
 565     }
 566     else {
 567         ok( 1, 'Person->new() can accept an array reference as an argument' );
 568     }
 569
 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
 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     );
 580 }
 581
 582 sub employee01 {
 583     my $employee = Employee->new(
 584         first_name => 'Amanda',
 585         last_name  => 'Palmer',
 586         title      => 'Singer',
 587     );
 588
 589     my $called     = 0;
 590     my $orig_super = \&Employee::super;
 591     no warnings 'redefine';
 592     local *Employee::super = sub { $called++; goto &$orig_super };
 593
 594     is(
 595         $employee->full_name, 'Amanda Palmer (Singer)',
 596         'full_name() is properly overriden in Employee'
 597     );
 598     ok( $called, 'Employee->full_name calls super()' );
 599 }
 600
 601 sub person02 {
 602     my $person = Person->new(
 603         first_name => 'Bilbo',
 604         last_name  => 'Baggins',
 605         balance    => 0,
 606     );
 607
 608     is(
 609         $person->as_string, 'Bilbo Baggins',
 610         'as_string() is correctly implemented'
 611     );
 612
 613     account_tests($person);
 614 }
 615
 616 sub employee02 {
 617     my $employee = Employee->new(
 618         first_name => 'Amanda',
 619         last_name  => 'Palmer',
 620         title      => 'Singer',
 621         balance    => 0,
 622     );
 623
 624     is(
 625         $employee->as_string, 'Amanda Palmer (Singer)',
 626         'as_string() uses overridden full_name method in Employee'
 627     );
 628
 629     account_tests($employee);
 630 }
 631
 632 sub person03 {
 633     my $person = Person->new(
 634         first_name => 'Bilbo',
 635         last_name  => 'Baggins',
 636     );
 637
 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     );
 646
 647     $person->title('Ringbearer');
 648     ok( $person->has_title,
 649         'Person has_title predicate is working correctly (returns true)' );
 650
 651     my $called    = 0;
 652     my $orig_pred = \&Person::has_title;
 653     no warnings 'redefine';
 654     local *Person::has_title = sub { $called++; goto &$orig_pred };
 655
 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' );
 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
 677     is(
 678         $employee->salary, 30000,
 679         'salary is calculated from salary_level, and salary passed to constructor is ignored'
 680     );
 681 }
 682
 683 sub person06 {
 684     my $account = BankAccount->new();
 685
 686     my $person = Person->new(
 687         first_name => 'Bilbo',
 688         last_name  => 'Baggins',
 689         account    => $account,
 690     );
 691
 692     is(
 693         $person->account, $account,
 694         'account object passed to Person->new is still in object'
 695     );
 696
 697     isa_ok( $person->account, 'BankAccount' );
 698     is(
 699         $person->account->owner, $person,
 700         'owner of bank account is person that created account'
 701     );
 702
 703     $person->deposit(10);
 704     is_deeply(
 705         $person->account->history, [100],
 706         'deposit was recorded in account history'
 707     );
 708
 709     $person->withdraw(15);
 710     is_deeply(
 711         $person->account->history, [ 100, 110 ],
 712         'withdrawal was recorded in account history'
 713     );
 714
 715     $person->withdraw(45);
 716     is_deeply(
 717         $person->account->history, [ 100, 110, 95 ],
 718         'withdrawal was recorded in account history'
 719     );
 720 }
 721
 722 sub account_tests {
 723     local $Test::Builder::Level = $Test::Builder::Level + 1;
 724
 725     my $person = shift;
 726     my $base_amount = shift || 0;
 727
 728     $person->deposit(50);
 729
 730     is(
 731         $person->balance, 50 + $base_amount,
 732         "balance is 50 + $base_amount",
 733     );
 734
 735     eval { $person->withdraw( 75 + $base_amount ) };
 736     like(
 737         $@, qr/\QBalance cannot be negative/,
 738         'cannot withdraw more than is in our balance'
 739     );
 740
 741     $person->withdraw(23);
 742
 743     is(
 744         $person->balance, 27 + $base_amount,
 745         'balance is 27 (+ starting balance) after deposit of 50 and withdrawal of 23'
 746     );
 747 }
 748
 749 1;