t/013_add_attribute_alternate.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 27;
   7 use Test::Exception;
   8
   9 BEGIN {
  10     use_ok('Class::MOP', ':universal');
  11 }
  12
  13 {
  14     package Point;
  15
  16     Point->meta->add_attribute('$.x' => (
  17         reader   => 'x',
  18         init_arg => 'x'
  19     ));
  20
  21     Point->meta->add_attribute('$.y' => (
  22         accessor => 'y',
  23         init_arg => 'y'
  24     ));
  25
  26     sub new {
  27         my $class = shift;
  28         bless $class->meta->construct_instance(@_) => $class;
  29     }
  30
  31     sub clear {
  32         my $self = shift;
  33         $self->{'$.x'} = 0;
  34         $self->{'$.y'} = 0;
  35     }
  36
  37     package Point3D;
  38     our @ISA = ('Point');
  39
  40     Point3D->meta->add_attribute('$:z' => (
  41         default => 123
  42     ));
  43
  44     sub clear {
  45         my $self = shift;
  46         $self->{'$:z'} = 0;
  47         $self->SUPER::clear();
  48     }
  49 }
  50
  51 isa_ok(Point->meta, 'Class::MOP::Class');
  52 isa_ok(Point3D->meta, 'Class::MOP::Class');
  53
  54 # ... test the classes themselves
  55
  56 my $point = Point->new('x' => 2, 'y' => 3);
  57 isa_ok($point, 'Point');
  58
  59 can_ok($point, 'x');
  60 can_ok($point, 'y');
  61 can_ok($point, 'clear');
  62
  63 {
  64     my $meta = $point->meta;
  65     is($meta, Point->meta(), '... got the meta from the instance too');
  66 }
  67
  68 is($point->y, 3, '... the $.y attribute was initialized correctly through the metaobject');
  69
  70 $point->y(42);
  71 is($point->y, 42, '... the $.y attribute was set properly with the accessor');
  72
  73 is($point->x, 2, '... the $.x attribute was initialized correctly through the metaobject');
  74
  75 $point->x(42);
  76 is($point->x, 2, '... the $.x attribute was not altered');
  77
  78 $point->clear();
  79
  80 is($point->y, 0, '... the $.y attribute was cleared correctly');
  81 is($point->x, 0, '... the $.x attribute was cleared correctly');
  82
  83 my $point3d = Point3D->new('x' => 1, 'y' => 2, '$:z' => 3);
  84 isa_ok($point3d, 'Point3D');
  85 isa_ok($point3d, 'Point');
  86
  87 {
  88     my $meta = $point3d->meta;
  89     is($meta, Point3D->meta(), '... got the meta from the instance too');
  90 }
  91
  92 can_ok($point3d, 'x');
  93 can_ok($point3d, 'y');
  94 can_ok($point3d, 'clear');
  95
  96 is($point3d->x, 1, '... the $.x attribute was initialized correctly through the metaobject');
  97 is($point3d->y, 2, '... the $.y attribute was initialized correctly through the metaobject');
  98 is($point3d->{'$:z'}, 3, '... the $:z attribute was initialized correctly through the metaobject');
  99
 100 {
 101     my $point3d = Point3D->new();
 102     isa_ok($point3d, 'Point3D');
 103
 104     is($point3d->x, undef, '... the $.x attribute was not initialized');
 105     is($point3d->y, undef, '... the $.y attribute was not initialized');
 106     is($point3d->{'$:z'}, 123, '... the $:z attribute was initialized correctly through the metaobject');
 107
 108 }