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