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