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