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 tests06 {
 152     {
 153         local $Test::Builder::Level = $Test::Builder::Level + 1;
 154
 155         has_meta('BankAccount');
 156         no_droppings('BankAccount');
 157
 158         has_rw_attr( 'BankAccount', 'balance' );
 159         has_rw_attr( 'BankAccount', 'owner' );
 160         has_ro_attr( 'BankAccount', 'history' );
 161     }
 162
 163     my $person_meta = Person->meta;
 164     ok( ! $person_meta->has_attribute('balance'),
 165         'Person class does not have a balance attribute' );
 166
 167     my $deposit_meth = $person_meta->get_method('deposit');
 168     isa_ok( $deposit_meth, 'Moose::Meta::Method::Delegation' );
 169
 170     my $withdraw_meth = $person_meta->get_method('withdraw');
 171     isa_ok( $withdraw_meth, 'Moose::Meta::Method::Delegation' );
 172
 173     my $ba_meta = BankAccount->meta;
 174     ok( $ba_meta->get_attribute('owner')->is_weak_ref,
 175         'owner attribute is a weak ref' );
 176
 177     person06();
 178 }
 179
 180
 181 sub has_meta {
 182     my $class = shift;
 183
 184     ok( $class->can('meta'), "$class has a meta() method" )
 185         or BAIL_OUT("Cannot run tests against a class without a meta!");
 186 }
 187
 188 sub check_isa {
 189     my $class   = shift;
 190     my $parents = shift;
 191
 192     my @isa = $class->meta->linearized_isa;
 193     shift @isa;    # returns $class as the first entry
 194
 195     my $count = scalar @{$parents};
 196     my $noun = PL_N( 'parent', $count );
 197
 198     is( scalar @isa, $count, "$class has $count $noun" );
 199
 200     for ( my $i = 0; $i < @{$parents}; $i++ ) {
 201         is( $isa[$i], $parents->[$i], "parent[$i] is $parents->[$i]" );
 202     }
 203 }
 204
 205 sub count_attrs {
 206     my $class = shift;
 207     my $count = shift;
 208
 209     my $noun = PL_N( 'attribute', $count );
 210     is( scalar $class->meta->get_attribute_list, $count,
 211         "$class defines $count $noun" );
 212 }
 213
 214 sub has_rw_attr {
 215     my $class = shift;
 216     my $name  = shift;
 217
 218     my $articled = A($name);
 219     ok( $class->meta->has_attribute($name),
 220         "$class has $articled attribute" );
 221
 222     my $attr = $class->meta->get_attribute($name);
 223
 224     is( $attr->get_read_method, $name,
 225         "$name attribute has a reader accessor - $name()" );
 226     is( $attr->get_write_method, $name,
 227         "$name attribute has a writer accessor - $name()" );
 228 }
 229
 230 sub has_ro_attr {
 231     my $class = shift;
 232     my $name  = shift;
 233
 234     my $articled = A($name);
 235     ok( $class->meta->has_attribute($name),
 236         "$class has $articled attribute" );
 237
 238     my $attr = $class->meta->get_attribute($name);
 239
 240     is( $attr->get_read_method, $name,
 241         "$name attribute has a reader accessor - $name()" );
 242     is( $attr->get_write_method, undef,
 243         "$name attribute does not have a writer" );
 244 }
 245
 246 sub has_method {
 247     my $class = shift;
 248     my $name  = shift;
 249
 250     my $articled = A($name);
 251     ok( $class->meta->has_method($name), "$class has $articled method" );
 252 }
 253
 254 sub has_overridden_method {
 255     my $class = shift;
 256     my $name  = shift;
 257
 258     my $articled = A($name);
 259     ok( $class->meta->has_method($name), "$class has $articled method" );
 260
 261     my $meth = $class->meta->get_method($name);
 262     isa_ok( $meth, 'Moose::Meta::Method::Overridden' );
 263 }
 264
 265 sub has_augmented_method {
 266     my $class = shift;
 267     my $name  = shift;
 268
 269     my $articled = A($name);
 270     ok( $class->meta->has_method($name), "$class has $articled method" );
 271
 272     my $meth = $class->meta->get_method($name);
 273     isa_ok( $meth, 'Moose::Meta::Method::Augmented' );
 274 }
 275
 276 sub no_droppings {
 277     my $class = shift;
 278
 279     ok( !$class->can('has'), "no Moose droppings in $class" );
 280 }
 281
 282 sub is_immutable {
 283     my $class = shift;
 284
 285     ok( $class->meta->is_immutable, "$class has been made immutable" );
 286 }
 287
 288 sub does_role {
 289     my $class = shift;
 290     my $role  = shift;
 291
 292     ok( $class->meta->does_role($role), "$class does the $role role" );
 293 }
 294
 295 sub person01 {
 296     my $person = Person->new(
 297         first_name => 'Bilbo',
 298         last_name  => 'Baggins',
 299     );
 300
 301     is( $person->full_name, 'Bilbo Baggins',
 302         'full_name() is correctly implemented' );
 303
 304     $person = Person->new( [ qw( Lisa Smith ) ] );
 305     is( $person->first_name, 'Lisa', 'set first_name from two-arg arrayref' );
 306     is( $person->last_name, 'Smith', 'set last_name from two-arg arrayref' );
 307
 308     eval { Person->new( sub { 'foo' } ) };
 309     like( $@, qr/\QSingle parameters to new() must be a HASH ref/,
 310           'Person constructor still rejects bad parameters' );
 311 }
 312
 313 sub employee01 {
 314     my $employee = Employee->new(
 315         first_name => 'Amanda',
 316         last_name  => 'Palmer',
 317         title      => 'Singer',
 318     );
 319
 320     my $called = 0;
 321     my $orig_super = \&Employee::super;
 322     no warnings 'redefine';
 323     local *Employee::super = sub { $called++; goto &$orig_super };
 324
 325     is( $employee->full_name, 'Amanda Palmer (Singer)',
 326         'full_name() is properly overriden in Employee' );
 327     ok( $called, 'Employee->full_name calls super()' );
 328 }
 329
 330 sub person02 {
 331     my $person = Person->new(
 332         first_name => 'Bilbo',
 333         last_name  => 'Baggins',
 334         balance    => 0,
 335     );
 336
 337     is( $person->as_string, 'Bilbo Baggins',
 338         'as_string() is correctly implemented' );
 339
 340     account_tests($person);
 341 }
 342
 343 sub employee02 {
 344     my $employee = Employee->new(
 345         first_name => 'Amanda',
 346         last_name  => 'Palmer',
 347         title      => 'Singer',
 348         balance    => 0,
 349     );
 350
 351     is( $employee->as_string, 'Amanda Palmer (Singer)',
 352         'as_string() uses overridden full_name method in Employee' );
 353
 354     account_tests($employee);
 355 }
 356
 357 sub person03 {
 358     my $person = Person->new(
 359         first_name => 'Bilbo',
 360         last_name  => 'Baggins',
 361     );
 362
 363     is( $person->full_name, 'Bilbo Baggins',
 364         'full_name() is correctly implemented for a Person without a title' );
 365     ok( !$person->has_title,
 366         'Person has_title predicate is working correctly (returns false)' );
 367
 368     $person->title('Ringbearer');
 369     ok( $person->has_title, 'Person has_title predicate is working correctly (returns true)' );
 370
 371     my $called = 0;
 372     my $orig_pred = \&Person::has_title;
 373     no warnings 'redefine';
 374     local *Person::has_title = sub { $called++; goto &$orig_pred };
 375
 376     is( $person->full_name, 'Bilbo Baggins (Ringbearer)',
 377         'full_name() is correctly implemented for a Person with a title' );
 378     ok( $called, 'full_name in person uses the predicate for the title attribute' );
 379
 380     $person->clear_title;
 381     ok( !$person->has_title, 'Person clear_title method cleared the title' );
 382
 383     account_tests( $person, 100 );
 384 }
 385
 386 sub employee03 {
 387     my $employee = Employee->new(
 388         first_name   => 'Jimmy',
 389         last_name    => 'Foo',
 390         salary_level => 3,
 391         salary       => 42,
 392     );
 393
 394     is( $employee->salary, 30000,
 395         'salary is calculated from salary_level, and salary passed to constructor is ignored' );
 396 }
 397
 398 sub person06 {
 399     my $person = Person->new(
 400         first_name => 'Bilbo',
 401         last_name  => 'Baggins',
 402     );
 403
 404     isa_ok( $person->account, 'BankAccount' );
 405     is( $person->account->owner, $person,
 406         'owner of bank account is person that created account' );
 407
 408     $person->deposit(10);
 409     is_deeply( $person->account->history, [ 100, 10 ],
 410                'deposit was recorded in account history' );
 411
 412     $person->withdraw(15);
 413     is_deeply( $person->account->history, [ 100, 10, -15 ],
 414                'withdrawal was recorded in account history' );
 415 }
 416
 417 sub account_tests {
 418     local $Test::Builder::Level = $Test::Builder::Level + 1;
 419
 420     my $person = shift;
 421     my $base_amount = shift || 0;
 422
 423     $person->deposit(50);
 424     eval { $person->withdraw( 75 + $base_amount ) };
 425     like( $@, qr/\QBalance cannot be negative/,
 426           'cannot withdraw more than is in our balance' );
 427
 428     $person->withdraw( 23 );
 429
 430     is( $person->balance, 27 + $base_amount,
 431         'balance is 27 (+ starting balance) after deposit of 50 and withdrawal of 23' );
 432 }
 433
 434 1;