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('BankAccount');
 263
 264     has_rw_attr( 'BankAccount', $_ ) for qw( balance owner );
 265
 266     my $ba_meta = BankAccount->meta;
 267
 268     ok(
 269         $ba_meta->get_attribute('owner')->is_weak_ref,
 270         'owner attribute is a weak ref'
 271     );
 272
 273     has_method( 'BankAccount', $_ ) for qw( deposit withdraw );
 274
 275     has_ro_attr( 'BankAccount', 'history' );
 276
 277     my $history_attr = $ba_meta->get_attribute('history');
 278
 279     is_deeply(
 280         $history_attr->default->(),
 281         [],
 282         'BankAccount history attribute defaults to []'
 283     );
 284
 285     {
 286         my $tc = $history_attr->type_constraint;
 287
 288         for my $invalid ( 0, 42, undef, {}, [ 'foo', 'bar' ] ) {
 289             my $str = defined $invalid ? $invalid : 'undef';
 290             ok(
 291                 !$tc->check($invalid),
 292                 "salary_level type rejects invalid value - $str"
 293             );
 294         }
 295
 296         for my $valid ( [], [1], [ 1, 2, 3 ], [ 1, -10, 9999 ] ) {
 297             ok(
 298                 $tc->check($valid),
 299                 "salary_level type accepts valid value"
 300             );
 301         }
 302     }
 303
 304     ok(
 305         $history_attr->meta()
 306             ->does_role('Moose::Meta::Attribute::Native::Trait::Array'),
 307         'BankAccount history attribute uses native delegation to an array ref'
 308     );
 309
 310     ok(
 311         $ba_meta->get_attribute('balance')->has_trigger,
 312         'BankAccount balance attribute has a trigger'
 313     );
 314
 315     has_meta('Person');
 316
 317     my $person_meta = Person->meta;
 318
 319     ok( !$person_meta->does_role('HasAccount'),
 320         'Person class does not do the HasAccount role' );
 321
 322     ok(
 323         !$person_meta->has_attribute('balance'),
 324         'Person class does not have a balance attribute'
 325     );
 326
 327     my $deposit_meth = $person_meta->get_method('deposit');
 328     isa_ok( $deposit_meth, 'Moose::Meta::Method::Delegation' );
 329
 330     my $withdraw_meth = $person_meta->get_method('withdraw');
 331     isa_ok( $withdraw_meth, 'Moose::Meta::Method::Delegation' );
 332
 333     person06();
 334
 335     has_meta('Employee');
 336
 337     no_droppings('BankAccount');
 338 }
 339
 340 sub has_meta {
 341     my $package = shift;
 342
 343     local $Test::Builder::Level = $Test::Builder::Level + 1;
 344
 345     use_ok($package)
 346         or BAIL_OUT("$package cannot be loaded");
 347
 348     ok( $package->can('meta'), "$package has a meta() method" )
 349         or BAIL_OUT(
 350         "$package does not have a meta() method (did you forget to 'use Moose'?)"
 351         );
 352 }
 353
 354 sub check_isa {
 355     my $class   = shift;
 356     my $parents = shift;
 357
 358     local $Test::Builder::Level = $Test::Builder::Level + 1;
 359
 360     my @isa = $class->meta->linearized_isa;
 361     shift @isa;    # returns $class as the first entry
 362
 363     my $count = scalar @{$parents};
 364     my $noun = PL_N( 'parent', $count );
 365
 366     is( scalar @isa, $count, "$class has $count $noun" );
 367
 368     for ( my $i = 0; $i < @{$parents}; $i++ ) {
 369         is( $isa[$i], $parents->[$i], "parent[$i] is $parents->[$i]" );
 370     }
 371 }
 372
 373 sub has_rw_attr {
 374     my $class      = shift;
 375     my $name       = shift;
 376     my $overridden = shift;
 377
 378     local $Test::Builder::Level = $Test::Builder::Level + 1;
 379
 380     my $articled = $overridden ? "an overridden $name" : A($name);
 381     ok(
 382         $class->meta->has_attribute($name),
 383         "$class has $articled attribute"
 384     );
 385
 386     my $attr = $class->meta->get_attribute($name);
 387
 388     is(
 389         $attr->get_read_method, $name,
 390         "$name attribute has a reader accessor - $name()"
 391     );
 392     is(
 393         $attr->get_write_method, $name,
 394         "$name attribute has a writer accessor - $name()"
 395     );
 396 }
 397
 398 sub has_ro_attr {
 399     my $class = shift;
 400     my $name  = shift;
 401
 402     local $Test::Builder::Level = $Test::Builder::Level + 1;
 403
 404     my $articled = A($name);
 405     ok(
 406         $class->meta->has_attribute($name),
 407         "$class has $articled attribute"
 408     );
 409
 410     my $attr = $class->meta->get_attribute($name);
 411
 412     is(
 413         $attr->get_read_method, $name,
 414         "$name attribute has a reader accessor - $name()"
 415     );
 416     is(
 417         $attr->get_write_method, undef,
 418         "$name attribute does not have a writer"
 419     );
 420 }
 421
 422 sub has_role_attr {
 423     my $role = shift;
 424     my $name = shift;
 425
 426     local $Test::Builder::Level = $Test::Builder::Level + 1;
 427
 428     my $articled = A($name);
 429     ok(
 430         $role->meta->get_attribute($name),
 431         "$role has $articled attribute"
 432     );
 433 }
 434
 435 sub has_method {
 436     my $package = shift;
 437     my $name    = shift;
 438
 439     local $Test::Builder::Level = $Test::Builder::Level + 1;
 440
 441     my $articled = A($name);
 442     ok( $package->meta->has_method($name), "$package has $articled method" );
 443 }
 444
 445 sub has_overridden_method {
 446     my $package = shift;
 447     my $name    = shift;
 448
 449     local $Test::Builder::Level = $Test::Builder::Level + 1;
 450
 451     my $articled = A($name);
 452     ok( $package->meta->has_method($name), "$package has $articled method" );
 453
 454     my $meth = $package->meta->get_method($name);
 455     isa_ok( $meth, 'Moose::Meta::Method::Overridden' );
 456 }
 457
 458 sub has_augmented_method {
 459     my $class = shift;
 460     my $name  = shift;
 461
 462     local $Test::Builder::Level = $Test::Builder::Level + 1;
 463
 464     my $articled = A($name);
 465     ok( $class->meta->has_method($name), "$class has $articled method" );
 466
 467     my $meth = $class->meta->get_method($name);
 468     isa_ok( $meth, 'Moose::Meta::Method::Augmented' );
 469 }
 470
 471 sub requires_method {
 472     my $package = shift;
 473     my $method  = shift;
 474
 475     local $Test::Builder::Level = $Test::Builder::Level + 1;
 476
 477     ok(
 478         $package->meta->requires_method($method),
 479         "$package requires the method $method"
 480     );
 481 }
 482
 483 sub no_droppings {
 484     my $package = shift;
 485
 486     local $Test::Builder::Level = $Test::Builder::Level + 1;
 487
 488     ok( !$package->can('has'), "no Moose droppings in $package" );
 489     ok( !$package->can('subtype'),
 490         "no Moose::Util::TypeConstraints droppings in $package" );
 491 }
 492
 493 sub is_immutable {
 494     my $class = shift;
 495
 496     local $Test::Builder::Level = $Test::Builder::Level + 1;
 497
 498     ok( $class->meta->is_immutable, "$class has been made immutable" );
 499 }
 500
 501 sub does_role {
 502     my $package = shift;
 503     my $role    = shift;
 504
 505     local $Test::Builder::Level = $Test::Builder::Level + 1;
 506
 507     ok( $package->meta->does_role($role), "$package does the $role role" );
 508 }
 509
 510 sub person01 {
 511     my $person = Person->new(
 512         first_name => 'Bilbo',
 513         last_name  => 'Baggins',
 514     );
 515
 516     is(
 517         $person->full_name, 'Bilbo Baggins',
 518         'full_name() is correctly implemented'
 519     );
 520
 521     $person = eval { Person->new( [ qw( Lisa Smith ) ] ) };
 522
 523     if ( my $e = $@ ) {
 524         diag(
 525             "Calling Person->new() with an array reference threw an error:\n$e"
 526         );
 527         BAIL_OUT(
 528             'You must implement Person->BUILDARGS correctly in order to continue these tests'
 529         );
 530     }
 531     else {
 532         ok( 1, 'Person->new() can accept an array reference as an argument' );
 533     }
 534
 535     is( $person->first_name, 'Lisa', 'set first_name from two-arg arrayref' );
 536     is( $person->last_name, 'Smith', 'set last_name from two-arg arrayref' );
 537
 538     eval {
 539         Person->new( sub {'foo'} );
 540     };
 541     like(
 542         $@, qr/\QSingle parameters to new() must be a HASH ref/,
 543         'Person constructor still rejects bad parameters'
 544     );
 545 }
 546
 547 sub employee01 {
 548     my $employee = Employee->new(
 549         first_name => 'Amanda',
 550         last_name  => 'Palmer',
 551         title      => 'Singer',
 552     );
 553
 554     my $called     = 0;
 555     my $orig_super = \&Employee::super;
 556     no warnings 'redefine';
 557     local *Employee::super = sub { $called++; goto &$orig_super };
 558
 559     is(
 560         $employee->full_name, 'Amanda Palmer (Singer)',
 561         'full_name() is properly overriden in Employee'
 562     );
 563     ok( $called, 'Employee->full_name calls super()' );
 564 }
 565
 566 sub person02 {
 567     my $person = Person->new(
 568         first_name => 'Bilbo',
 569         last_name  => 'Baggins',
 570         balance    => 0,
 571     );
 572
 573     is(
 574         $person->as_string, 'Bilbo Baggins',
 575         'as_string() is correctly implemented'
 576     );
 577
 578     account_tests($person);
 579 }
 580
 581 sub employee02 {
 582     my $employee = Employee->new(
 583         first_name => 'Amanda',
 584         last_name  => 'Palmer',
 585         title      => 'Singer',
 586         balance    => 0,
 587     );
 588
 589     is(
 590         $employee->as_string, 'Amanda Palmer (Singer)',
 591         'as_string() uses overridden full_name method in Employee'
 592     );
 593
 594     account_tests($employee);
 595 }
 596
 597 sub person03 {
 598     my $person = Person->new(
 599         first_name => 'Bilbo',
 600         last_name  => 'Baggins',
 601     );
 602
 603     is(
 604         $person->full_name, 'Bilbo Baggins',
 605         'full_name() is correctly implemented for a Person without a title'
 606     );
 607     ok(
 608         !$person->has_title,
 609         'Person has_title predicate is working correctly (returns false)'
 610     );
 611
 612     $person->title('Ringbearer');
 613     ok( $person->has_title,
 614         'Person has_title predicate is working correctly (returns true)' );
 615
 616     my $called    = 0;
 617     my $orig_pred = \&Person::has_title;
 618     no warnings 'redefine';
 619     local *Person::has_title = sub { $called++; goto &$orig_pred };
 620
 621     is(
 622         $person->full_name, 'Bilbo Baggins (Ringbearer)',
 623         'full_name() is correctly implemented for a Person with a title'
 624     );
 625     ok( $called,
 626         'full_name in person uses the predicate for the title attribute' );
 627
 628     $person->clear_title;
 629     ok( !$person->has_title, 'Person clear_title method cleared the title' );
 630
 631     account_tests( $person, 100 );
 632 }
 633
 634 sub employee03 {
 635     my $employee = Employee->new(
 636         first_name   => 'Jimmy',
 637         last_name    => 'Foo',
 638         salary_level => 3,
 639         salary       => 42,
 640     );
 641
 642     is(
 643         $employee->salary, 30000,
 644         'salary is calculated from salary_level, and salary passed to constructor is ignored'
 645     );
 646 }
 647
 648 sub person06 {
 649     my $person = Person->new(
 650         first_name => 'Bilbo',
 651         last_name  => 'Baggins',
 652     );
 653
 654     isa_ok( $person->account, 'BankAccount' );
 655     is(
 656         $person->account->owner, $person,
 657         'owner of bank account is person that created account'
 658     );
 659
 660     $person->deposit(10);
 661     is_deeply(
 662         $person->account->history, [100],
 663         'deposit was recorded in account history'
 664     );
 665
 666     $person->withdraw(15);
 667     is_deeply(
 668         $person->account->history, [ 100, 110 ],
 669         'withdrawal was recorded in account history'
 670     );
 671
 672     $person->withdraw(45);
 673     is_deeply(
 674         $person->account->history, [ 100, 110, 95 ],
 675         'withdrawal was recorded in account history'
 676     );
 677 }
 678
 679 sub account_tests {
 680     local $Test::Builder::Level = $Test::Builder::Level + 1;
 681
 682     my $person = shift;
 683     my $base_amount = shift || 0;
 684
 685     $person->deposit(50);
 686
 687     is(
 688         $person->balance, 50 + $base_amount,
 689         "balance is 50 + $base_amount",
 690     );
 691
 692     eval { $person->withdraw( 75 + $base_amount ) };
 693     like(
 694         $@, qr/\QBalance cannot be negative/,
 695         'cannot withdraw more than is in our balance'
 696     );
 697
 698     $person->withdraw(23);
 699
 700     is(
 701         $person->balance, 27 + $base_amount,
 702         'balance is 27 (+ starting balance) after deposit of 50 and withdrawal of 23'
 703     );
 704 }
 705
 706 1;