t/011_create_class.t

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