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 has_meta {
 109     my $class = shift;
 110
 111     ok( $class->can('meta'), "$class has a meta() method" )
 112         or BAIL_OUT("Cannot run tests against a class without a meta!");
 113 }
 114
 115 sub check_isa {
 116     my $class   = shift;
 117     my $parents = shift;
 118
 119     my @isa = $class->meta->linearized_isa;
 120     shift @isa;    # returns $class as the first entry
 121
 122     my $count = scalar @{$parents};
 123     my $noun = PL_N( 'parent', $count );
 124
 125     is( scalar @isa, $count, "$class has $count $noun" );
 126
 127     for ( my $i = 0; $i < @{$parents}; $i++ ) {
 128         is( $isa[$i], $parents->[$i], "parent[$i] is $parents->[$i]" );
 129     }
 130 }
 131
 132 sub count_attrs {
 133     my $class = shift;
 134     my $count = shift;
 135
 136     my $noun = PL_N( 'attribute', $count );
 137     is( scalar $class->meta->get_attribute_list, $count,
 138         "$class defines $count $noun" );
 139 }
 140
 141 sub has_rw_attr {
 142     my $class = shift;
 143     my $name  = shift;
 144
 145     my $articled = A($name);
 146     ok( $class->meta->has_attribute($name),
 147         "$class has $articled attribute" );
 148
 149     my $attr = $class->meta->get_attribute($name);
 150
 151     is( $attr->get_read_method, $name,
 152         "$name attribute has a reader accessor - $name()" );
 153     is( $attr->get_write_method, $name,
 154         "$name attribute has a writer accessor - $name()" );
 155 }
 156
 157 sub has_ro_attr {
 158     my $class = shift;
 159     my $name  = shift;
 160
 161     my $articled = A($name);
 162     ok( $class->meta->has_attribute($name),
 163         "$class has $articled attribute" );
 164
 165     my $attr = $class->meta->get_attribute($name);
 166
 167     is( $attr->get_read_method, $name,
 168         "$name attribute has a reader accessor - $name()" );
 169     is( $attr->get_write_method, undef,
 170         "$name attribute does not have a writer" );
 171 }
 172
 173 sub has_method {
 174     my $class = shift;
 175     my $name  = shift;
 176
 177     my $articled = A($name);
 178     ok( $class->meta->has_method($name), "$class has $articled method" );
 179 }
 180
 181 sub has_overridden_method {
 182     my $class = shift;
 183     my $name  = shift;
 184
 185     my $articled = A($name);
 186     ok( $class->meta->has_method($name), "$class has $articled method" );
 187
 188     my $meth = $class->meta->get_method($name);
 189     isa_ok( $meth, 'Moose::Meta::Method::Overridden' );
 190 }
 191
 192 sub no_droppings {
 193     my $class = shift;
 194
 195     ok( !$class->can('has'), "no Moose droppings in $class" );
 196 }
 197
 198 sub is_immutable {
 199     my $class = shift;
 200
 201     ok( $class->meta->is_immutable, "$class has been made immutable" );
 202 }
 203
 204 sub does_role {
 205     my $class = shift;
 206     my $role  = shift;
 207
 208     ok( $class->meta->does_role($role), "$class does the $role role" );
 209 }
 210
 211 sub person01 {
 212     my $person = Person->new(
 213         first_name => 'Bilbo',
 214         last_name  => 'Baggins',
 215     );
 216
 217     is( $person->full_name, 'Bilbo Baggins',
 218         'full_name() is correctly implemented' );
 219 }
 220
 221 sub employee01 {
 222     my $employee = Employee->new(
 223         first_name => 'Amanda',
 224         last_name  => 'Palmer',
 225         title      => 'Singer',
 226     );
 227
 228     is(        $employee->full_name, 'Amanda Palmer (Singer)',        'full_name() is properly overriden in Employee'    );
 229 }
 230
 231 sub person02 {
 232     my $person = Person->new(
 233         first_name => 'Bilbo',
 234         last_name  => 'Baggins',
 235         balance    => 0,
 236     );
 237
 238     is( $person->as_string, 'Bilbo Baggins',
 239         'as_string() is correctly implemented' );
 240
 241     account_tests($person);
 242 }
 243
 244 sub employee02 {
 245     my $employee = Employee->new(
 246         first_name => 'Amanda',
 247         last_name  => 'Palmer',
 248         title      => 'Singer',
 249         balance    => 0,
 250     );
 251
 252     is( $employee->as_string, 'Amanda Palmer (Singer)',
 253         'as_string() uses overridden full_name method in Employee' );
 254
 255     account_tests($employee);
 256 }
 257
 258 sub person03 {
 259     my $person = Person->new(
 260         first_name => 'Bilbo',
 261         last_name  => 'Baggins',
 262     );
 263
 264     is( $person->full_name, 'Bilbo Baggins',
 265         'full_name() is correctly implemented for a Person without a title' );
 266     ok( !$person->has_title,
 267         'Person has_title predicate is working correctly' );
 268
 269     $person->title('Ringbearer');
 270     ok( $person->has_title, 'Person has_title predicate is working correctly' );
 271     is( $person->full_name, 'Bilbo Baggins (Ringbearer)',
 272         'full_name() is correctly implemented for a Person with a title' );
 273
 274     $person->clear_title;
 275     ok( !$person->has_title, 'Person clear_title method cleared the title' );
 276
 277     account_tests( $person, 100 );
 278 }
 279
 280 sub employee03 {
 281     my $employee = Employee->new(
 282         first_name   => 'Jimmy',
 283         last_name    => 'Foo',
 284         salary_level => 3,
 285         salary       => 42,
 286     );
 287
 288     is( $employee->salary, 30000,
 289         'salary is calculated from salary_level, and salary passed to constructor is ignored' );
 290 }
 291
 292 sub account_tests {
 293     local $Test::Builder::Level = $Test::Builder::Level + 1;
 294
 295     my $person = shift;
 296     my $base_amount = shift || 0;
 297
 298     $person->deposit(50);
 299     eval { $person->withdraw( 75 + $base_amount ) };
 300     like( $@, qr/\QBalance cannot be negative/,
 301           'cannot withdraw more than is in our balance' );
 302
 303     $person->withdraw( 23 );
 304
 305     is( $person->balance, 27 + $base_amount,
 306         'balance is 27 (+ starting balance) after deposit of 50 and withdrawal of 23' );
 307 }
 308
 309 1;