t/000-recipes/001_point.t

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