t/000_recipes/moose_cookbook_basics_recipe1.t

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use Test::More 'no_plan';
   5 use Test::Exception;
   6 $| = 1;
   7
   8
   9
  10 # =begin testing SETUP
  11 {
  12
  13   package Point;
  14   use Mouse;
  15
  16   has 'x' => (isa => 'Int', is => 'rw', required => 1);
  17   has 'y' => (isa => 'Int', is => 'rw', required => 1);
  18
  19   sub clear {
  20       my $self = shift;
  21       $self->x(0);
  22       $self->y(0);
  23   }
  24
  25   package Point3D;
  26   use Mouse;
  27
  28   extends 'Point';
  29
  30   has 'z' => (isa => 'Int', is => 'rw', required => 1);
  31
  32   after 'clear' => sub {
  33       my $self = shift;
  34       $self->z(0);
  35   };
  36
  37   package main;
  38
  39   # hash or hashrefs are ok for the constructor
  40   my $point1 = Point->new(x => 5, y => 7);
  41   my $point2 = Point->new({x => 5, y => 7});
  42
  43   my $point3d = Point3D->new(x => 5, y => 42, z => -5);
  44 }
  45
  46
  47
  48 # =begin testing
  49 {
  50 my $point = Point->new( x => 1, y => 2 );
  51 isa_ok( $point, 'Point' );
  52 isa_ok( $point, 'Mouse::Object' );
  53
  54 is( $point->x, 1, '... got the right value for x' );
  55 is( $point->y, 2, '... got the right value for y' );
  56
  57 $point->y(10);
  58 is( $point->y, 10, '... got the right (changed) value for y' );
  59
  60 dies_ok {
  61     $point->y('Foo');
  62 }
  63 '... cannot assign a non-Int to y';
  64
  65 dies_ok {
  66     Point->new();
  67 }
  68 '... must provide required attributes to new';
  69
  70 $point->clear();
  71
  72 is( $point->x, 0, '... got the right (cleared) value for x' );
  73 is( $point->y, 0, '... got the right (cleared) value for y' );
  74
  75 # check the type constraints on the constructor
  76
  77 lives_ok {
  78     Point->new( x => 0, y => 0 );
  79 }
  80 '... can assign a 0 to x and y';
  81
  82 dies_ok {
  83     Point->new( x => 10, y => 'Foo' );
  84 }
  85 '... cannot assign a non-Int to y';
  86
  87 dies_ok {
  88     Point->new( x => 'Foo', y => 10 );
  89 }
  90 '... cannot assign a non-Int to x';
  91
  92 # Point3D
  93
  94 my $point3d = Point3D->new( { x => 10, y => 15, z => 3 } );
  95 isa_ok( $point3d, 'Point3D' );
  96 isa_ok( $point3d, 'Point' );
  97 isa_ok( $point3d, 'Mouse::Object' );
  98
  99 is( $point3d->x,     10, '... got the right value for x' );
 100 is( $point3d->y,     15, '... got the right value for y' );
 101 is( $point3d->{'z'}, 3,  '... got the right value for z' );
 102
 103 $point3d->clear();
 104
 105 is( $point3d->x, 0, '... got the right (cleared) value for x' );
 106 is( $point3d->y, 0, '... got the right (cleared) value for y' );
 107 is( $point3d->z, 0, '... got the right (cleared) value for z' );
 108
 109 dies_ok {
 110     Point3D->new( x => 10, y => 'Foo', z => 3 );
 111 }
 112 '... cannot assign a non-Int to y';
 113
 114 dies_ok {
 115     Point3D->new( x => 'Foo', y => 10, z => 3 );
 116 }
 117 '... cannot assign a non-Int to x';
 118
 119 dies_ok {
 120     Point3D->new( x => 0, y => 10, z => 'Bar' );
 121 }
 122 '... cannot assign a non-Int to z';
 123
 124 dies_ok {
 125     Point3D->new( x => 10, y => 3 );
 126 }
 127 '... z is a required attribute for Point3D';
 128
 129 # test some class introspection
 130
 131 can_ok( 'Point', 'meta' );
 132 isa_ok( Point->meta, 'Mouse::Meta::Class' );
 133
 134 can_ok( 'Point3D', 'meta' );
 135 isa_ok( Point3D->meta, 'Mouse::Meta::Class' );
 136
 137 isnt( Point->meta, Point3D->meta,
 138     '... they are different metaclasses as well' );
 139
 140 # poke at Point
 141
 142 is_deeply(
 143     [ Point->meta->superclasses ],
 144     ['Mouse::Object'],
 145     '... Point got the automagic base class'
 146 );
 147
 148 my @Point_methods = qw(meta x y clear);
 149 my @Point_attrs = ( 'x', 'y' );
 150
 151 is_deeply(
 152     [ sort @Point_methods ],
 153     [ sort Point->meta->get_method_list() ],
 154     '... we match the method list for Point'
 155 );
 156
 157 is_deeply(
 158     [ sort @Point_attrs ],
 159     [ sort Point->meta->get_attribute_list() ],
 160     '... we match the attribute list for Point'
 161 );
 162
 163 foreach my $method (@Point_methods) {
 164     ok( Point->meta->has_method($method),
 165         '... Point has the method "' . $method . '"' );
 166 }
 167
 168 foreach my $attr_name (@Point_attrs) {
 169     ok( Point->meta->has_attribute($attr_name),
 170         '... Point has the attribute "' . $attr_name . '"' );
 171     my $attr = Point->meta->get_attribute($attr_name);
 172     ok( $attr->has_type_constraint,
 173         '... Attribute ' . $attr_name . ' has a type constraint' );
 174     isa_ok( $attr->type_constraint, 'Mouse::Meta::TypeConstraint' );
 175     is( $attr->type_constraint->name, 'Int',
 176         '... Attribute ' . $attr_name . ' has an Int type constraint' );
 177 }
 178
 179 # poke at Point3D
 180
 181 is_deeply(
 182     [ Point3D->meta->superclasses ],
 183     ['Point'],
 184     '... Point3D gets the parent given to it'
 185 );
 186
 187 my @Point3D_methods = qw( meta z clear );
 188 my @Point3D_attrs   = ('z');
 189
 190 is_deeply(
 191     [ sort @Point3D_methods ],
 192     [ sort Point3D->meta->get_method_list() ],
 193     '... we match the method list for Point3D'
 194 );
 195
 196 is_deeply(
 197     [ sort @Point3D_attrs ],
 198     [ sort Point3D->meta->get_attribute_list() ],
 199     '... we match the attribute list for Point3D'
 200 );
 201
 202 foreach my $method (@Point3D_methods) {
 203     ok( Point3D->meta->has_method($method),
 204         '... Point3D has the method "' . $method . '"' );
 205 }
 206
 207 foreach my $attr_name (@Point3D_attrs) {
 208     ok( Point3D->meta->has_attribute($attr_name),
 209         '... Point3D has the attribute "' . $attr_name . '"' );
 210     my $attr = Point3D->meta->get_attribute($attr_name);
 211     ok( $attr->has_type_constraint,
 212         '... Attribute ' . $attr_name . ' has a type constraint' );
 213     isa_ok( $attr->type_constraint, 'Mouse::Meta::TypeConstraint' );
 214     is( $attr->type_constraint->name, 'Int',
 215         '... Attribute ' . $attr_name . ' has an Int type constraint' );
 216 }
 217 }
 218
 219
 220
 221
 222 1;