The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;
use warnings;

use Test::More 'tests' => 36;

package AA; {
    use Object::InsideOut;

    my %aa : Field({'acc'=>'aa', 'type' => 'num'});

    my $id = 1;

    sub id : ID {
        return ($id++);
    }
}


package BB; {
    use Object::InsideOut;

    my %bb : Field( { 'get' => 'bb', 'Set' => 'set_bb' } );

    my %init_args : InitArgs = (
        'BB' => {
            'Field'     => \%bb,
            'Default'   => 'def',
            'Regex'     => qr/bb/i,
        },
    );
}


package AB; {
    use Object::InsideOut qw(AA BB);

    my %data : Field({'acc'=>'data'});
    my %info : Field('gET'=>'info_get', 'SET'=>'info_set');

    my %init_args : InitArgs = (
        'data' => {
            'Field' => \%data,
        },
        'info' => {
            'FIELD' => \%info,
            'DEF'   => ''
        },
    );
}


package foo; {
    use Object::InsideOut;
}


package main;

MAIN:
{
    my $obj;
    eval { $obj = AA->new(); };
    ok(! $@, '->new() ' . $@);
    can_ok($obj, qw(new clone DESTROY CLONE aa));

    ok($$obj == 1,                  'Object ID: ' . $$obj);
    ok(! defined($obj->aa),         'No default');
    ok($obj->aa(42) == 42,          'Set ->aa()');
    ok($obj->aa == 42,              'Get ->aa() == ' . $obj->aa);

    eval { $obj = BB->new(); };
    can_ok($obj, qw(bb set_bb));
    ok(! $@, '->new() ' . $@);
    ok($$obj == 2,                  'Object ID: ' . $$obj);
    is($obj->bb, 'def',             'Default: ' . $obj->bb);
    is($obj->set_bb('foo'), 'foo',  'Set ->set_bb()');
    is($obj->bb, 'foo',             'Get ->bb() eq ' . $obj->bb);

    eval { $obj = BB->new('bB' => 'baz'); };
    ok(! $@, '->new() ' . $@);
    ok($$obj == 3,                  'Object ID: ' . $$obj);
    is($obj->bb, 'baz',             'Init: ' . $obj->bb);
    is($obj->set_bb('foo'), 'foo',  'Set ->set_bb()');
    is($obj->bb, 'foo',             'Get ->bb() eq ' . $obj->bb);

    eval { $obj = AB->new(); };
    can_ok($obj, qw(aa bb set_bb data info_get info_set));
    ok(! $@, '->new() ' . $@);
    ok($$obj == 4,                  'Object ID: ' . $$obj);
    is($obj->bb, 'def',             'Default: ' . $obj->bb);
    is($obj->set_bb('foo'), 'foo',  'Set ->set_bb()');
    is($obj->bb, 'foo',             'Get ->bb() eq ' . $obj->bb);
    is($obj->bb, 'foo',             'Get ->bb() eq ' . $obj->bb);
    is($obj->info_get(), '',        '->info_get() eq ' . $obj->info_get());
    $obj->info_set('test');
    is($obj->info_get(), 'test',    'Set: ->info_get() eq ' . $obj->info_get());

    # Test that IDs are being reclaimed
    my $id;
    {
        my $x = foo->new();
        $id = $$x;
    }
    for (1..10) {
        my $x = foo->new();
        is($$x, $id, 'ID reclaimed');
    }
}

exit(0);

# EOF