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' => 34;

package My::Class; {
    use Object::InsideOut;

    sub is_scalar :Private { return (! ref(shift)); }

    sub is_int {
        my $arg = $_[0];
        return (Scalar::Util::looks_like_number($arg) &&
                (int($arg) == $arg));
    }

    my @aa :Field('acc'=>'aa', 'type' => 'array');
    my @as :Field('acc'=>'as', 'type' => 'array(My::Class)');
    my @ar :Field('acc'=>'ar', 'type' => 'array_ref');
    my @cc :Field({'acc'=>'cc', 'type' => sub{ shift > 0 } });
    my @hh :Field('acc'=>'hh', 'type' => 'hash');
    my @hr :Field('acc'=>'hr', 'type' => 'hashref');
    my @mc :Field({'acc'=>'mc', 'type' => 'My::Class'});
    my @nn :Field({'acc'=>'nn', 'type' => 'num'});
    my @sr :Field({'acc'=>'sr', 'type' => 'scalar_ref'});
    my @ss :Field
           :Acc(ss)
           :Type(\&My::Class::is_scalar);
    my @scal :Field :Acc(scal) :Type(scalar);

    my %init_args :InitArgs = (
        'DATA' => {
            'Field' => \@nn,
            'Type'  => \&is_int,
        },
        'INFO' => {
            'Type'  => sub { $_[0] }
        },
        'BAD' => {
            'Type'  => sub { shift > 0 }
        },
        'SC' => {
            'Field' => \@scal,
            'Type'  => 'scalar',
        }
    );
}

package main;

MAIN:
{
    my $obj = My::Class->new('DATA' => 5, 'SC' => 'bork');

    $obj->aa('test');
    is_deeply($obj->aa(), ['test']              => 'Array single value');
    $obj->aa('zero', 5);
    is_deeply($obj->aa(), ['zero', 5]           => 'Array multiple values');
    $obj->aa(['x', 42, 'z']);
    is_deeply($obj->aa(), ['x', 42, 'z']        => 'Array ref value');

    {
        my $a = My::Class->new();
        my $b = My::Class->new();
        my $c = My::Class->new();

        $obj->as($a);
        is_deeply($obj->as(), [$a]              => 'Array single class');
        $obj->as($a, $b, $c);
        is_deeply($obj->as(), [$a, $b, $c]      => 'Array multiple class');
        $obj->as([$c, $a, $b]);
        is_deeply($obj->as(), [$c, $a, $b]      => 'Array ref class');
    }

    eval { $obj->ar('test'); };
    like($@->message, qr/Wrong type/            => 'Not array ref');
    $obj->ar([3, [ 'a' ]]);
    is_deeply($obj->ar(), [3, [ 'a' ]]          => 'Array ref');

    $obj->cc(12);
    is($obj->cc(), 12                           => 'Type sub');
    eval { $obj->cc(-5); };
    like($@->message, qr/failed type check/     => 'Type failure');
    eval { $obj->cc('hello'); };
    like($@->message, qr/Problem with type check routine/  => 'Type sub failure');

    $obj->hh('x' => 5);
    is_deeply($obj->hh(), {'x'=>5}              => 'Hash single pair');
    $obj->hh('a' => 'z', '0' => '9');
    is_deeply($obj->hh(), {'a'=>'z','0'=>'9'}   => 'Hash multiple pairs');
    $obj->hh({'2b'=>'not'});
    is_deeply($obj->hh(), {'2b'=>'not'}         => 'Hash ref value');

    eval { $obj->hr('test'); };
    like($@->message, qr/Wrong type/            => 'Not hash ref');
    $obj->hr({'frog'=>{'prince'=>'John'}});
    is_deeply($obj->hr(), {'frog'=>{'prince'=>'John'}} => 'Hash ref');

    my $obj2 = My::Class->new();
    $obj->mc($obj2);
    my $obj3 = $obj->mc();
    isa_ok($obj3, 'My::Class'                   => 'Object');
    is($$obj3, $$obj2                           => 'Objects equal');
    eval { $obj2->mc('test'); };
    like($@->message, qr/Wrong type/            => 'Not object');

    $obj->nn(99);
    is_deeply($obj->nn(), 99                    => 'Numeric');
    eval { $obj->nn('x'); };
    like($@->message, qr/Bad argument/          => 'Numeric failure');

    $obj->ss('hello');
    is($obj->ss(), 'hello'                      => 'Scalar');
    eval { $obj->ss([1]); };
    like($@->message, qr/failed type check/     => 'Scalar failure');

    is($obj->scal(), 'bork'                     => 'Scalar');
    $obj->scal('foo');
    is($obj->scal(), 'foo'                      => 'Scalar');
    eval { $obj->scal(bless({}, 'Foo')); };
    like($@->message, qr/Bad argument/          => 'Scalar failure');

    eval { $obj->sr('test'); };
    like($@->message, qr/Wrong type/            => 'Not scalar ref');
    my $x = 42;
    $obj->sr(\$x);
    is($obj->sr(), \$x                          => 'Scalar ref');
    my $y = $obj->sr();
    is($$y, 42                                  => 'Scalar ref value');

    eval { $obj2 = My::Class->new('DATA' => 'hello'); };
    like($@->message, qr/failed type check/     => 'Type failure');

    eval { $obj2 = My::Class->new('INFO' => ''); };
    like($@->message, qr/failed type check/     => 'Type failure');

    eval { $obj2 = My::Class->new('SC' => []); };
    like($@->message, qr/Bad value/             => 'Scalar failure');

    eval { $obj2 = My::Class->new('BAD' => ''); };
    like($@->message, qr/Problem with type check routine/  => 'Type sub failure');

    $obj = bless({}, 'SomeClass');
    ok(UNIVERSAL::isa($obj, '') ||
       UNIVERSAL::isa($obj, 0) ||
       UNIVERSAL::isa($obj, 'SomeClass'), 'isa works');
}

exit(0);

# EOF