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( 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     count_attrs( 'Person', 2 );
  17
  18     has_rw_attr( 'Person', $_ ) for qw( first_name last_name );
  19
  20     has_method( 'Person', 'full_name' );
  21
  22     no_droppings('Person');
  23     is_immutable('Person');
  24
  25     person01();
  26
  27     has_meta('Employee');
  28
  29     check_isa( 'Employee', [ 'Person', 'Moose::Object' ] );
  30
  31     count_attrs( 'Employee', 3 );
  32
  33     has_rw_attr( 'Employee', $_ ) for qw( position salary );
  34     has_ro_attr( 'Employee', 'ssn' );
  35
  36     has_overridden_method( 'Employee', 'full_name' );
  37
  38     employee01();
  39 }
  40
  41 sub has_meta {
  42     my $class = shift;
  43
  44     ok( $class->can('meta'), "$class has a meta() method" )
  45         or BAIL_OUT("Cannot run tests against a class without a meta!");
  46 }
  47
  48 sub check_isa {
  49     my $class   = shift;
  50     my $parents = shift;
  51
  52     my @isa = $class->meta->linearized_isa;
  53     shift @isa;    # returns $class as the first entry
  54
  55     my $count = scalar @{$parents};
  56     my $noun = PL_N( 'parent', $count );
  57
  58     is( scalar @isa, $count, "$class has $count $noun" );
  59
  60     for ( my $i = 0; $i < @{$parents}; $i++ ) {
  61         is( $isa[$i], $parents->[$i], "parent[$i] is $parents->[$i]" );
  62     }
  63 }
  64
  65 sub count_attrs {
  66     my $class = shift;
  67     my $count = shift;
  68
  69     my $noun = PL_N( 'attribute', $count );
  70     is( scalar $class->meta->get_attribute_list, $count,
  71         "$class defines $count $noun" );
  72 }
  73
  74 sub has_rw_attr {
  75     my $class = shift;
  76     my $name  = shift;
  77
  78     ok( $class->meta->has_attribute($name), "$class has attribute - $name" );
  79
  80     my $attr = $class->meta->get_attribute($name);
  81
  82     is( $attr->get_read_method, $name,
  83         "$name attribute has a reader accessor - $name()" );
  84     is( $attr->get_write_method, $name,
  85         "$name attribute has a writer accessor - $name()" );
  86 }
  87
  88 sub has_ro_attr {
  89     my $class = shift;
  90     my $name  = shift;
  91
  92     ok( $class->meta->has_attribute($name), "$class has attribute - $name" );
  93
  94     my $attr = $class->meta->get_attribute($name);
  95
  96     is( $attr->get_read_method, $name,
  97         "$name attribute has a reader accessor - $name()" );
  98     is( $attr->get_write_method, undef,
  99         "$name attribute does not have a writer" );
 100 }
 101
 102 sub has_method {
 103     my $class = shift;
 104     my $name  = shift;
 105
 106     ok( $class->meta->has_method($name), "$class has a $name method" );
 107 }
 108
 109 sub has_overridden_method {
 110     my $class = shift;
 111     my $name  = shift;
 112
 113     ok( $class->meta->has_method($name), "$class has a $name method" );
 114
 115     my $meth = $class->meta->get_method($name);
 116     isa_ok( $meth, 'Moose::Meta::Method::Overridden' );
 117 }
 118
 119 sub no_droppings {
 120     my $class = shift;
 121
 122     ok( !$class->can('has'), "no Moose droppings in $class" );
 123 }
 124
 125 sub is_immutable {
 126     my $class = shift;
 127
 128     ok( $class->meta->is_immutable, "$class has been made immutable" );
 129 }
 130
 131 sub person01 {
 132     my $person = Person->new(
 133         first_name => 'Bilbo',
 134         last_name  => 'Baggins',
 135     );
 136
 137     is( $person->full_name, 'Bilbo Baggins',
 138         'full_name() is correctly implemented' );
 139 }
 140
 141 sub employee01 {
 142     my $employee = Employee->new(
 143         first_name => 'Amanda',
 144         last_name  => 'Palmer',
 145         position   => 'Singer',
 146     );
 147
 148     is( $employee->full_name, 'Amanda Palmer (Singer)',
 149         'full_name() is properly overriden in Employee' );
 150 }
 151
 152
 153 1;