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

#MODIFY_CODE_ATTRIBUTES
#MODIFY_HASH_ATTRIBUTES
#MODIFY_ARRAY_ATTRIBUTES
#MODIFY_SCALAR_ATTRIBUTES

package Foo; {
    use Object::InsideOut;

    sub _add_defaults :MOD_SCALAR_ATTRS
    {
        my ($pkg, $scalar, @attrs) = @_;
        my @unused_attrs;   # List of any unhandled attributes

        while (my $attr = shift(@attrs)) {
            if ($attr =~ /^D\('?([^)']+)'?\)/i) {
                $$scalar = $1;
                Test::More::ok(1, "Foo: $attr");
            } else {
                push(@unused_attrs, $attr);
            }
        }

        return (@unused_attrs);
    }

    sub _make_fields :MOD_ARRAY_ATTRS
    {
        my ($pkg, $array, @attrs) = @_;
        my @unused_attrs;   # List of any unhandled attributes

        while (my $attr = shift(@attrs)) {
            if ($attr =~ /^F\('?([^)']+)'?\)/i) {
                push(@unused_attrs, "Field('all' => '$1')");
            } else {
                push(@unused_attrs, $attr);
            }
        }

        return (@unused_attrs);
    }

    my @foo :F(foo);    # :Field('all'=>'foo')
}

package Bork; {
    use Object::InsideOut;

    sub _check_attr :MOD_ARRAY_ATTRS
    {
        my ($pkg, $array, @attrs) = @_;
        my @unused_attrs;   # List of any unhandled attributes

        while (my $attr = shift(@attrs)) {
            if ($attr eq 'Test') {
                Test::More::ok(1, "Bork: $attr");
            } else {
                push(@unused_attrs, $attr);
            }
        }

        return (@unused_attrs);
    }
}

package Bar; {
    use Object::InsideOut qw(Foo Bork);

    my $iam :D(ima_foo);

    sub iam { return ($iam); }

    my @bar :F('bar') Test;

    sub _fetch_attrs :FETCH_CODE_ATTRS
    {
        my ($pkg, $ref) = @_;
        if ($ref == \&iam) {
            return ('Method');
        }
    }
}

package main;

MAIN:
{
    is(Bar::iam, 'ima_foo'      => 'Scalar default');

    my $obj = Bar->new();
    can_ok($obj => qw(foo bar));
    is((attributes::get(Bar->can('iam')))[0], 'Method', 'Fetch attr');
}

exit(0);

# EOF