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