whoops

[gitmo/Class-MOP.git] / t / 011_create_class.t

#!/usr/bin/perl

use strict;
use warnings;

use Test::More tests => 28;
use Test::Exception;

BEGIN {
    use_ok('Class::MOP');        
}

my $Point = Class::MOP::Class->create('Point' => (
    version    => '0.01',
    attributes => [
        Class::MOP::Attribute->new('$.x' => (
            reader   => 'x',
            init_arg => 'x'
        )),
        Class::MOP::Attribute->new('$.y' => (
            accessor => 'y',
            init_arg => 'y'
        )),        
    ],
    methods => {
        'new' => sub {
            my $class = shift;
            my $instance = $class->meta->construct_instance(@_);
            bless $instance => $class;
        },
        'clear' => sub {
            my $self = shift;
            $self->{'$.x'} = 0;
            $self->{'$.y'} = 0;            
        }
    }
));

my $Point3D = Class::MOP::Class->create('Point3D' => (
    version      => '0.01',    
    superclasses => [ 'Point' ],
    attributes => [
        Class::MOP::Attribute->new('$:z' => (
            default  => 123
        )),
    ],
    methods => {
        'clear' => sub {
            my $self = shift;
            $self->{'$:z'} = 0;
            $self->SUPER::clear();
        }
    }
));

isa_ok($Point, 'Class::MOP::Class');
isa_ok($Point3D, 'Class::MOP::Class');

# ... test the classes themselves

my $point = Point->new('x' => 2, 'y' => 3);
isa_ok($point, 'Point');

can_ok($point, 'x');
can_ok($point, 'y');
can_ok($point, 'clear');

{
    my $meta = $point->meta;
    is($meta, Point->meta(), '... got the meta from the instance too');
}

is($point->y, 3, '... the $.y attribute was initialized correctly through the metaobject');

$point->y(42);
is($point->y, 42, '... the $.y attribute was set properly with the accessor');

is($point->x, 2, '... the $.x attribute was initialized correctly through the metaobject');

dies_ok {
    $point->x(42);
} '... cannot write to a read-only accessor';
is($point->x, 2, '... the $.x attribute was not altered');

$point->clear();

is($point->y, 0, '... the $.y attribute was cleared correctly');
is($point->x, 0, '... the $.x attribute was cleared correctly');

my $point3d = Point3D->new('x' => 1, 'y' => 2, '$:z' => 3);
isa_ok($point3d, 'Point3D');
isa_ok($point3d, 'Point');

{
    my $meta = $point3d->meta;
    is($meta, Point3D->meta(), '... got the meta from the instance too');
}

can_ok($point3d, 'x');
can_ok($point3d, 'y');
can_ok($point3d, 'clear');

is($point3d->x, 1, '... the $.x attribute was initialized correctly through the metaobject');
is($point3d->y, 2, '... the $.y attribute was initialized correctly through the metaobject');
is($point3d->{'$:z'}, 3, '... the $:z attribute was initialized correctly through the metaobject');

{
    my $point3d = Point3D->new();
    isa_ok($point3d, 'Point3D');
    
    is($point3d->x, undef, '... the $.x attribute was not initialized');
    is($point3d->y, undef, '... the $.y attribute was not initialized');
    is($point3d->{'$:z'}, 123, '... the $:z attribute was initialized correctly through the metaobject');    
        
}