t/011_create_class.t

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