accept fully named args to Class::MOP::Method::wrap

[gitmo/Class-MOP.git] / t / 013_add_attribute_alternate.t

#!/usr/bin/perl

use strict;
use warnings;

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

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

{
    package Point;
    use metaclass;

    Point->meta->add_attribute('$.x' => (
        reader   => 'x',
        init_arg => 'x'
    ));

    Point->meta->add_attribute('$.y' => (
        accessor => 'y',
        init_arg => 'y'
    ));

    sub new {
        my $class = shift;
        bless $class->meta->construct_instance(@_) => $class;
    }

    sub clear {
        my $self = shift;
        $self->{'$.x'} = 0;
        $self->{'$.y'} = 0;            
    }

    package Point3D;
    our @ISA = ('Point');
    
    Point3D->meta->add_attribute('$:z' => (
        default => 123
    ));

    sub clear {
        my $self = shift;
        $self->{'$:z'} = 0;
        $self->SUPER::clear();
    }
}

isa_ok(Point->meta, 'Class::MOP::Class');
isa_ok(Point3D->meta, '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');    
        
}