#!./perl -w

BEGIN {

chdir 't' if -d 't';

@INC = '../lib';

}

#

# A couple of simple classes to use as struct elements.

#

package aClass;

sub new { bless {}, shift }

sub meth { 42 }

package RecClass;

sub new { bless {}, shift }

#

# The first of our Class::Struct based objects.

#

package MyObj;

use Class::Struct;

use Class::Struct 'struct'; # test out both forms

use Class::Struct SomeClass => { SomeElem => '$' };

struct( s => '$', a => '@', h => '%', c => 'aClass' );

#

# The second Class::Struct objects:

# test the 'compile-time without package name' feature.

#

package MyOther;

use Class::Struct s => '$', a => '@', h => '%', c => 'aClass';

#

# test overriden accessors

#

package OverrideAccessor;

use Class::Struct;

{

no warnings qw(Class::Struct);

struct( 'OverrideAccessor', { count => '$' } );

}

sub count {

my ($self,$count) = @_;

if ( @_ >= 2 ) {

$self->{'OverrideAccessor::count'} = $count + 9;

}

return $self->{'OverrideAccessor::count'};

}

#

# back to main...

#

package main;

use Test::More;

my $obj = MyObj->new;

isa_ok $obj, 'MyObj';

$obj->s('foo');

is $obj->s(), 'foo';

isa_ok $obj->a, 'ARRAY';

$obj->a(2, 'secundus');

is $obj->a(2), 'secundus';

$obj->a([4,5,6]);

is $obj->a(1), 5;

isa_ok $obj->h, 'HASH';

$obj->h('x', 10);

is $obj->h('x'), 10;

$obj->h({h=>7,r=>8,f=>9});

is $obj->h('r'), 8;

is $obj->c, undef;

$obj = MyObj->new( c => aClass->new );

isa_ok $obj->c, 'aClass';

is $obj->c->meth(), 42;

$obj = MyOther->new;

isa_ok $obj, 'MyOther';

$obj->s('foo');

is $obj->s(), 'foo';

isa_ok $obj->a, 'ARRAY';

$obj->a(2, 'secundus');

is $obj->a(2), 'secundus';

$obj->a([4,5,6]);

is $obj->a(1), 5;

isa_ok $obj->h, 'HASH';

$obj->h('x', 10);

is $obj->h('x'), 10;

$obj->h({h=>7,r=>8,f=>9});

is $obj->h('r'), 8;

is $obj->c, undef;

$obj = MyOther->new( c => aClass->new );

isa_ok $obj->c, 'aClass';

is $obj->c->meth(), 42;

my $obk = SomeClass->new();

$obk->SomeElem(123);

is $obk->SomeElem(), 123;

my $recobj = RecClass->new();

isa_ok $recobj, 'RecClass';

my $override_obj = OverrideAccessor->new( count => 3 );

is $override_obj->count, 12;

$override_obj->count( 1 );

is $override_obj->count, 10;

use Class::Struct Kapow => { z_zwap => 'Regexp', sploosh => 'MyObj' };

is eval { main->new(); }, undef,

'No new method injected into current package';

my $obj3 = Kapow->new();

isa_ok $obj3, 'Kapow';

is $obj3->z_zwap, undef, 'No z_zwap member by default';

is $obj3->sploosh, undef, 'No sploosh member by default';

$obj3->z_zwap(qr//);

isa_ok $obj3->z_zwap, 'Regexp', 'Can set z_zwap member';

$obj3->sploosh(MyObj->new(s => 'pie'));

isa_ok $obj3->sploosh, 'MyObj',

'Can set sploosh member to object of correct class';

is $obj3->sploosh->s, 'pie', 'Can set sploosh member to correct object';

my $obj4 = Kapow->new( z_zwap => qr//, sploosh => MyObj->new(a => ['Good']) );

isa_ok $obj4, 'Kapow';

isa_ok $obj4->z_zwap, 'Regexp', 'Initialised z_zwap member';

isa_ok $obj4->sploosh, 'MyObj', 'Initialised sploosh member';

is_deeply $obj4->sploosh->a, ['Good'], 'with correct object';

my $obj5 = Kapow->new( sploosh => { h => {perl => 'rules'} } );

isa_ok $obj5, 'Kapow';

is $obj5->z_zwap, undef, 'No z_zwap member by default';

isa_ok $obj5->sploosh, 'MyObj', 'Initialised sploosh member from hash';

is_deeply $obj5->sploosh->h, { perl => 'rules'} , 'with correct object';

is eval {

package MyObj;

struct( s => '$', a => '@', h => '%', c => 'aClass' );

}, undef, 'Calling struct a second time fails';

like $@, qr/^function 'new' already defined in package MyObj/,

'fails with the expected error';

is eval { MyObj->new( a => {} ) }, undef,

'Using a hash where an array reference is expected';

like $@, qr/^Initializer for a must be array reference/,

'fails with the expected error';

is eval { MyObj->new( h => [] ) }, undef,

'Using an array where a hash reference is expected';

like $@, qr/^Initializer for h must be hash reference/,

'fails with the expected error';

is eval { Kapow->new( sploosh => { h => [perl => 'rules'] } ); }, undef,

'Using an array where a hash reference is expected in an initialiser list';

like $@, qr/^Initializer for h must be hash reference/,

'fails with the expected error';

is eval { Kapow->new( sploosh => [ h => {perl => 'rules'} ] ); }, undef,

"Using an array for a member object's initialiser list";

like $@, qr/^Initializer for sploosh must be hash or MyObj reference/,

'fails with the expected error';

is eval {

package Crraack;

use Class::Struct 'struct';

struct( 'pow' => '@$%!' );

}, undef, 'Bad type fails';

like $@, qr/^'\@\$\%\!' is not a valid struct element type/,

'with the expected error';

is eval {

$obj3->sploosh(MyOther->new(s => 3.14));

}, undef, 'Setting member to the wrong class of object fails';

like $@, qr/^sploosh argument is wrong class/,

'with the expected error';

is $obj3->sploosh->s, 'pie', 'Object is unchanged';

is eval {

$obj3->sploosh(MyObj->new(s => 3.14), 'plop');

}, undef, 'Too many arguments to setter fails';

like $@, qr/^Too many args to sploosh/,

'with the expected error';

is $obj3->sploosh->s, 'pie', 'Object is unchanged';

is eval {

package Blurp;

use Class::Struct 'struct';

struct( Blurp => {}, 'Bonus!' );

}, undef, 'hash based class with extra argument fails';

like $@, qr/\Astruct usage error.*\n.*\n/,

'with the expected confession';

is eval {

package Zamm;

use Class::Struct 'struct';

struct( Zamm => [], 'Bonus!' );

}, undef, 'array based class with extra argument fails';

like $@, qr/\Astruct usage error.*\n.*\n/,

'with the expected confession';

is eval {

package Thwapp;

use Class::Struct 'struct';

struct( Thwapp => ['Bonus!'] );

}, undef, 'array based class with extra constructor argument fails';

like $@, qr/\Astruct usage error.*\n.*\n/,

'with the expected confession';

is eval {

package Rakkk;

use Class::Struct 'struct';

struct( z_zwap => 'Regexp', sploosh => 'MyObj', 'Bonus' );

}, undef, 'default array based class with extra constructor argument fails';

like $@, qr/\Astruct usage error.*\n.*\n/,

'with the expected confession';

is eval {

package Awk;

use parent -norequire, 'Urkkk';

use Class::Struct 'struct';

struct( beer => 'foamy' );

}, undef, '@ISA is not allowed';

like $@, qr/^struct class cannot be a subclass \(\@ISA not allowed\)/,

'with the expected error';

done_testing;