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