t/000-recipes/001_point.t

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