File Coverage

blib/lib/Object/InsideOut.pm

Criterion	Covered	Total	%
statement	1370	1704	80.4
branch	660	944	69.9
condition	160	282	56.7
subroutine	94	101	93.0
pod	9	16	56.2
total	2293	3047	75.2

package Object::InsideOut; {

require 5.006;

use strict;
use warnings;

our $VERSION = '4.04';
$VERSION = eval $VERSION;

use Object::InsideOut::Exception 4.04;
use Object::InsideOut::Util 4.04 qw(create_object hash_re is_it make_shared);
use Object::InsideOut::Metadata 4.04;

require B;

use Scalar::Util 1.10;
if (! Scalar::Util->can('weaken')) {
    OIO->Trace(0);
    OIO::Code->die(
        'message' => q/Cannot use 'pure perl' version of Scalar::Util - 'weaken' missing/,
        'Info'    => 'Upgrade/reinstall your version of Scalar::Util');
}


### Global Data ###

my %GBL;
if (! exists($GBL{'GBL_SET'})) {
    %GBL = (
        'GBL_SET' => 1,         # Control flag for initializing this hash

        %GBL,                   # Contains 'perm', 'merge', 'attr', 'meta'
                                #   from compilation phase

        init => 1,              # Initialization flag
        # term                  # Termination flag

        export => [             # Exported subroutines (i.e., @EXPORT)
            qw(new clone meta set DESTROY)
        ],

        tree => {               # Class trees
            td => {},           #  Top down
            bu => {},           #  Bottom up
        },

        asi => {},              # Reverse 'isa'

        id => {
            obj   => {},        # Object IDs
            reuse => {},        # Reclaimed obj IDs
        },

        fld => {
            ref  => {},         # :Field
            # new
            type => {},         # :Type
            weak => {},         # :Weak
            deep => {},         # :Deep
            def  => {},         # :Default

            regen => {          # Fix field keys during CLONE
                type => [],
                weak => [],
                deep => [],
            },
        },
        hash_only => {},        # :Hash_Only

        args      => {},        # :InitArgs

        sub => {
            id   => {},         # :ID
            init => {},         # :Init
            pre  => {},         # :PreInit
            repl => {},         # :Replicate
            dest => {},         # :Destroy
            auto => {},         # :Automethod
            # cumu              # :Cumulative
            # chain             # :Chained
            # ol                # :*ify (overload)
        },

        dump => {
            dumper => {},       # :Dumper
            pumper => {},       # :Pumper
            fld    => {},       # Field info
            args   => [],       # InitArgs info
        },

        heritage => {},         # Foreign class inheritance data

        # Currently executing thread
        tid => (($threads::threads) ? threads->tid() : 0),
        # pids                  # Pseudo-forks

        obj => {},              # Object registry for thread cloning

        share => {              # Object sharing between threads
            cl  => {},
            ok  => $threads::shared::threads_shared,
            # obj               # Tracks TIDs for shared objects
        },

        # cache                 # Object initialization activity cache
    );

    # Add metadata
    $GBL{'meta'}{'add'}{'Object::InsideOut'} = {
        'import'                 => {'hidden' => 1},
        'MODIFY_CODE_ATTRIBUTES' => {'hidden' => 1},
        'inherit'                => {'restricted' => 1},
        'disinherit'             => {'restricted' => 1},
        'heritage'               => {'restricted' => 1},
    };

    if ($threads::shared::threads_shared && ($threads::shared::VERSION lt '0.96')) {
        *threads::shared::is_shared = \&threads::shared::_id;
    }
}


### Import ###

# Doesn't export anything - just builds class trees and handles module flags
sub import
{
    my $self = shift;      # Ourself (i.e., 'Object::InsideOut')
    if (Scalar::Util::blessed($self)) {
        OIO::Method->die('message' => q/'import' called as an object method/);
    }

    # Invoked via inheritance - ignore
    if ($self ne 'Object::InsideOut') {
        if (Exporter->can('import')) {
            my $lvl = $Exporter::ExportLevel;
            $Exporter::ExportLevel = (caller() eq 'Object::InsideOut') ? 3 : 1;
            $self->Exporter::import(@_);
            $Exporter::ExportLevel = $lvl;
        }
        return;
    }

    my $class = caller();   # The class that is using us
    if (! $class || $class eq 'main') {
        OIO::Code->die(
            'message' => q/'import' invoked from 'main'/,
            'Info'    => "Can't use 'use Object::InsideOut;' or 'Object::InsideOut->import();' inside application code");
    }

    no strict 'refs';

    # Check for class's global sharing flag
    # (normally set in the app's main code)
    if (defined(${$class.'::shared'})) {
        set_sharing($class, ${$class.'::shared'}, (caller())[1..2]);
    }

    # Check for class's global 'storable' flag
    # (normally set in the app's main code)
    {
        no warnings 'once';
        if (${$class.'::storable'}) {
            push(@_, 'Storable');
        }
    }

    # Import packages and handle :SHARED flag
    my @packages;
    while (my $pkg = shift) {
        next if (! $pkg);    # Ignore empty strings and such

        # Handle thread object sharing flag
        if ($pkg =~ /^:(NOT?_?|!)?SHAR/i) {
            my $sharing = (defined($1)) ? 0 : 1;
            set_sharing($class, $sharing, (caller())[1..2]);
            next;
        }

        # Handle hash fields only flag
        if ($pkg =~ /^:HASH/i) {
            $GBL{'hash_only'}{$class} = [ $class, (caller())[1,2] ];
            next;
        }

        # Restricted class
        if ($pkg =~ /^:RESTRICT(?:ED)?(?:\((.*)\))?/i) {
            *{$class.'::new'}
                = wrap_RESTRICTED($class, 'new',
                                  sub { goto &Object::InsideOut::new },
                                  [ grep {$_} split(/[,'\s]+/, $1 || '') ]);
            $GBL{'meta'}{'add'}{$class}{'new'} = { 'kind' => 'constructor',
                                                   'merge_args' => 1,
                                                   'restricted' => 1 };
            next;
        }

        # Private class
        if ($pkg =~ /^:PRIV(?:ATE)?(?:\((.*)\))?/i) {
            *{$class.'::new'}
                = wrap_PRIVATE($class, 'new',
                               sub { goto &Object::InsideOut::new },
                               [ $class, grep {$_} split(/[,'\s]+/, $1 || '') ]);
            $GBL{'meta'}{'add'}{$class}{'new'} = { 'kind' => 'constructor',
                                                   'merge_args' => 1,
                                                   'private' => 1 };
            next;
        }

        # Public class
        if ($pkg =~ /^:PUB/i) {
            *{$class.'::new'} = sub { goto &Object::InsideOut::new };
            $GBL{'meta'}{'add'}{$class}{'new'} = { 'kind' => 'constructor',
                                                   'merge_args' => 1 };
            next;
        }

        # Handle secure flag
        if ($pkg =~ /^:SECUR/i) {
            $pkg = 'Object::InsideOut::Secure';
        }

        # Load the package, if needed
        if (! $class->isa($pkg)) {
            # If no package symbols, then load it
            if (! grep { $_ !~ /::$/ } keys(%{$pkg.'::'})) {
                eval "require $pkg";
                if ($@) {
                    OIO::Code->die(
                        'message' => "Failure loading package '$pkg'",
                        'Error'   => $@);
                }
                # Empty packages make no sense
                if (! grep { $_ !~ /::$/ } keys(%{$pkg.'::'})) {
                    OIO::Code->die('message' => "Package '$pkg' is empty");
                }
            }

            # Add to package list
            push(@packages, $pkg);
        }


        # Import the package, if needed
        if (ref($_[0])) {
            my $imports = shift;
            if (ref($imports) ne 'ARRAY') {
                OIO::Code->die('message' => "Arguments to '$pkg' must be contained within an array reference: $imports");
            }
            eval { $pkg->import(@{$imports}); };
            if ($@) {
                OIO::Code->die(
                    'message' => "Failure running 'import' on package '$pkg'",
                    'Error'   => $@);
            }
        }
    }

    # Create class tree
    my @tree;
    my %seen;   # Used to prevent duplicate entries in @tree
    my $need_oio = 1;
    foreach my $parent (@packages) {
        if (exists($GBL{'tree'}{'td'}{$parent})) {
            # Inherit from Object::InsideOut class
            foreach my $ancestor (@{$GBL{'tree'}{'td'}{$parent}}) {
                if (! exists($seen{$ancestor})) {
                    push(@tree, $ancestor);
                    $GBL{'asi'}{$ancestor}{$class} = undef;
                    $seen{$ancestor} = undef;
                }
            }
            push(@{$class.'::ISA'}, $parent);
            $need_oio = 0;

        } else { # Inherit from foreign class
            # Get inheritance 'classes' hash
            if (! exists($GBL{'heritage'}{$class})) {
                create_heritage($class);
            }
            # Add parent to inherited classes
            $GBL{'heritage'}{$class}{'cl'}{$parent} = undef;
        }
    }

    # Add Object::InsideOut to class's @ISA array, if needed
    if ($need_oio) {
        push(@{$class.'::ISA'}, 'Object::InsideOut');
    }

    # Add calling class to tree
    if (! exists($seen{$class})) {
        push(@tree, $class);
    }

    # Save the trees
    $GBL{'tree'}{'td'}{$class} = \@tree;
    @{$GBL{'tree'}{'bu'}{$class}} = reverse(@tree);

    $GBL{'init'} = 1;   # Need to initialize
}


### Attribute Handling ###

# Handles subroutine attributes supported by this package.
# See 'perldoc attributes' for details.
sub MODIFY_CODE_ATTRIBUTES
{
    my ($pkg, $code, @attrs) = @_;

    # Call attribute handlers in the class tree
    if (exists($GBL{'attr'}{'MOD'}{'CODE'})) {
        @attrs = CHECK_ATTRS('CODE', $pkg, $code, @attrs);
        return if (! @attrs);
    }

    # Save caller info with code ref for error reporting purposes
    my %info = (
        pkg  => $pkg,
        code => $code,
        wrap => $code,
        loc  => [ $pkg, (caller(2))[1,2] ],
    );

    # Special handling for :Restricted :Cumulative/:Chained methods
    if ((my ($restrict) = grep(/^RESTRICT(?:ED)?$/i, @attrs))  &&
        (grep { ($_ =~ /^CUM(?:ULATIVE)?$/i) ||
                ($_ =~ /^CHAIN(?:ED)?$/i) } @attrs))
    {
        @attrs = grep { $_ !~ /^RESTRICT(?:ED)?$/i } @attrs;
        ($info{'exempt'}) = $restrict =~ /^RESTRICT(?:ED)?\((.*)\)/;
    }

    my @unused_attrs;   # List of any unhandled attributes

    # Save the code refs in the appropriate hashes
    while (my $attribute = shift(@attrs)) {
        my ($attr, $arg) = $attribute =~ /(\w+)(?:[(]\s*(.*)\s*[)])?/;
        $attr = uc($attr);

        if ($attr eq 'ID') {
            $GBL{'sub'}{'id'}{$pkg} = \%info;
            push(@attrs, $arg || 'HIDDEN');
            $GBL{'init'} = 1;

        } elsif ($attr eq 'PREINIT') {
            $GBL{'sub'}{'pre'}{$pkg} = $code;
            push(@attrs, $arg || 'HIDDEN');

        } elsif ($attr eq 'INIT') {
            $GBL{'sub'}{'init'}{$pkg} = $code;
            push(@attrs, $arg || 'HIDDEN');

        } elsif ($attr =~ /^REPL(?:ICATE)?$/) {
            $GBL{'sub'}{'repl'}{$pkg} = $code;
            push(@attrs, $arg || 'HIDDEN');

        } elsif ($attr =~ /^DEST(?:ROY)?$/) {
            $GBL{'sub'}{'dest'}{$pkg} = $code;
            push(@attrs, $arg || 'HIDDEN');

        } elsif ($attr =~ /^AUTO(?:METHOD)?$/) {
            $GBL{'sub'}{'auto'}{$pkg} = $code;
            push(@attrs, $arg || 'HIDDEN');
            $GBL{'init'} = 1;

        } elsif ($attr =~ /^CUM(?:ULATIVE)?$/) {
            push(@{$GBL{'sub'}{'cumu'}{'new'}{($arg && $arg =~ /BOTTOM/i) ? 'bu' : 'td'}}, \%info);
            $GBL{'init'} = 1;

        } elsif ($attr =~ /^CHAIN(?:ED)?$/) {
            push(@{$GBL{'sub'}{'chain'}{'new'}{($arg && $arg =~ /BOTTOM/i) ? 'bu' : 'td'}}, \%info);
            $GBL{'init'} = 1;

        } elsif ($attr =~ /^DUMP(?:ER)?$/) {
            $GBL{'dump'}{'dumper'}{$pkg} = $code;
            push(@attrs, $arg || 'HIDDEN');

        } elsif ($attr =~ /^PUMP(?:ER)?$/) {
            $GBL{'dump'}{'pumper'}{$pkg} = $code;
            push(@attrs, $arg || 'HIDDEN');

        } elsif ($attr =~ /^RESTRICT(?:ED)?$/) {
            $info{'exempt'} = $arg;
            push(@{$GBL{'perm'}{'restr'}}, \%info);
            $GBL{'init'} = 1;

        } elsif ($attr =~ /^PRIV(?:ATE)?$/) {
            $info{'exempt'} = $arg;
            push(@{$GBL{'perm'}{'priv'}}, \%info);
            $GBL{'init'} = 1;

        } elsif ($attr =~ /^HIDD?EN?$/) {
            push(@{$GBL{'perm'}{'hide'}}, \%info);
            $GBL{'init'} = 1;

        } elsif ($attr =~ /^SUB/) {
            push(@{$GBL{'meta'}{'subr'}}, \%info);
            if ($arg) {
                push(@attrs, $arg);
            }
            $GBL{'init'} = 1;

        } elsif ($attr =~ /^METHOD/ && $attribute ne 'method') {
            if ($arg) {
                $info{'kind'} = lc($arg);
                push(@{$GBL{'meta'}{'method'}}, \%info);
                $GBL{'init'} = 1;
            }

        } elsif ($attr =~ /^MERGE/) {
            push(@{$GBL{'merge'}}, \%info);
            if ($arg) {
                push(@attrs, $arg);
            }
            $GBL{'init'} = 1;

        } elsif ($attr =~ /^MOD(?:IFY)?_(ARRAY|CODE|HASH|SCALAR)_ATTR/) {
            install_ATTRIBUTES(\%GBL);
            $GBL{'attr'}{'MOD'}{$1}{$pkg} = $code;
            push(@attrs, $arg || 'HIDDEN');

        } elsif ($attr =~ /^FETCH_(ARRAY|CODE|HASH|SCALAR)_ATTR/) {
            install_ATTRIBUTES(\%GBL);
            push(@{$GBL{'attr'}{'FETCH'}{$1}}, $code);
            push(@attrs, $arg || 'HIDDEN');

        } elsif ($attr eq 'SCALARIFY') {
            OIO::Attribute->die(
                'message' => q/:SCALARIFY not allowed/,
                'Info'    => q/The scalar of an object is its object ID, and can't be redefined/,
                'ignore_package' => 'attributes');

        } elsif (my ($ify) = grep { $_ eq $attr } (qw(STRINGIFY
                                                      NUMERIFY
                                                      BOOLIFY
                                                      ARRAYIFY
                                                      HASHIFY
                                                      GLOBIFY
                                                      CODIFY)))
        {
            # Overload (-ify) attributes
            $info{'ify'} = $ify;
            push(@{$GBL{'sub'}{'ol'}}, \%info);
            $GBL{'init'} = 1;

        } elsif ($attr !~ /^PUB(LIC)?$/) {   # PUBLIC is ignored
            # Not handled
            push(@unused_attrs, $attribute);
        }
    }

    # If using Attribute::Handlers, send it any unused attributes
    if (@unused_attrs &&
        Attribute::Handlers::UNIVERSAL->can('MODIFY_CODE_ATTRIBUTES'))
    {
        return (Attribute::Handlers::UNIVERSAL::MODIFY_CODE_ATTRIBUTES($pkg, $code, @unused_attrs));
    }

    # Return any unused attributes
    return (@unused_attrs);
}

my $BALANCED_PARENS; # Must declare before assigning (so var in scope for regex)
$BALANCED_PARENS = qr{(?>(?:(?>[^()]+)|[(](??{$BALANCED_PARENS})[)])*)};

# Handles hash field and :InitArgs attributes.
sub MODIFY_HASH_ATTRIBUTES :Sub
{
    my ($pkg, $hash, @attrs) = @_;

    # Call attribute handlers in the class tree
    if (exists($GBL{'attr'}{'MOD'}{'HASH'})) {
        @attrs = CHECK_ATTRS('HASH', $pkg, $hash, @attrs);
        return if (! @attrs);
    }

    my @unused_attrs;   # List of any unhandled attributes

    # Process attributes
    foreach my $attr (@attrs) {
        # Declaration for object field hash
        if ($attr =~ /^(?:Field|[GS]et|Acc|Com|Mut|St(?:an)?d|LV(alue)?|All|R(?:ead)?O(?:nly)?|Arg|Type|Hand)/i) {
            # Save hash ref and attribute
            # Accessors will be built during initialization
            if ($attr =~ /^(?:Field|Type)/i) {
                unshift(@{$GBL{'fld'}{'new'}{$pkg}}, [ $hash, $attr ]);
            } else {
                push(@{$GBL{'fld'}{'new'}{$pkg}}, [ $hash, $attr ]);
            }
            $GBL{'init'} = 1;   # Flag that initialization is required
        }

        # Weak field
        elsif ($attr =~ /^Weak$/i) {
            $GBL{'fld'}{'weak'}{$hash} = 1;
            push(@{$GBL{'fld'}{'regen'}{'weak'}}, $hash);
        }

        # Deep cloning field
        elsif ($attr =~ /^Deep$/i) {
            $GBL{'fld'}{'deep'}{$hash} = 1;
            push(@{$GBL{'fld'}{'regen'}{'deep'}}, $hash);
        }

        # Defaults
        elsif ($attr =~ /^Def(?:ault)?[(]($BALANCED_PARENS)[)]$/i) {
            my $val;
            eval "package $pkg; use $]; \$val = sub { my \$self = \$_[0]; $1 }";
            if ($@) {
                OIO::Attribute->die(
                    'location'  => [ $pkg, (caller(2))[1,2] ],
                    'message'   => "Bad ':Default' attribute in package '$pkg'",
                    'Attribute' => $attr,
                    'Error'     => $@);
            }
            push(@{$GBL{'fld'}{'def'}{$pkg}}, [ $hash, $val ]);
        }

        # Sequentials
        elsif ($attr =~ /^Seq(?:uence)?(?:From)?[(]($BALANCED_PARENS)[)]$/i) {
            my $val = $1;
            eval qq{
                package $pkg;
                my \$next = $val;
                \$val = eval{ \$next->can('next') }
                        ? sub { \$next->next() }
                        : sub { \$next++ };
            };
            if ($@) {
                OIO::Attribute->die(
                    'location'  => [ $pkg, (caller(2))[1,2] ],
                    'message'   => "Bad ':SequenceFrom' attribute in package '$pkg'",
                    'Attribute' => $attr,
                    'Error'     => $@);
            }
            push(@{$GBL{'fld'}{'def'}{$pkg}}, [ $hash, $val ]);
        }

        # Field name for dump
        elsif ($attr =~ /^Name\s*[(]\s*'?([^)'\s]+)'?\s*[)]/i) {
            $GBL{'dump'}{'fld'}{$pkg}{$1} = { fld => $hash, src => 'Name' };
        }

        # Declaration for object initializer hash
        elsif ($attr =~ /^InitArgs?$/i) {
            $GBL{'args'}{$pkg} = $hash;
            push(@{$GBL{'dump'}{'args'}}, $pkg);
        }

        # Unhandled
        # (Must filter out ':shared' attribute due to Perl bug)
        elsif ($attr ne 'shared') {
            push(@unused_attrs, $attr);
        }
    }

    # If using Attribute::Handlers, send it any unused attributes
    if (@unused_attrs &&
        Attribute::Handlers::UNIVERSAL->can('MODIFY_HASH_ATTRIBUTES'))
    {
        return (Attribute::Handlers::UNIVERSAL::MODIFY_HASH_ATTRIBUTES($pkg, $hash, @unused_attrs));
    }

    # Return any unused attributes
    return (@unused_attrs);
}


# Handles array field attributes.
sub MODIFY_ARRAY_ATTRIBUTES :Sub
{
    my ($pkg, $array, @attrs) = @_;

    # Call attribute handlers in the class tree
    if (exists($GBL{'attr'}{'MOD'}{'ARRAY'})) {
        @attrs = CHECK_ATTRS('ARRAY', $pkg, $array, @attrs);
        return if (! @attrs);
    }

    my @unused_attrs;   # List of any unhandled attributes

    # Process attributes
    foreach my $attr (@attrs) {
        # Declaration for object field array
        if ($attr =~ /^(?:Field|[GS]et|Acc|Com|Mut|St(?:an)?d|LV(alue)?|All|R(?:ead)?O(?:nly)?|Arg|Type|Hand)/i) {
            # Save array ref and attribute
            # Accessors will be built during initialization
            if ($attr =~ /^(?:Field|Type)/i) {
                unshift(@{$GBL{'fld'}{'new'}{$pkg}}, [ $array, $attr ]);
            } else {
                push(@{$GBL{'fld'}{'new'}{$pkg}}, [ $array, $attr ]);
            }
            $GBL{'init'} = 1;   # Flag that initialization is required
        }

        # Weak field
        elsif ($attr =~ /^Weak$/i) {
            $GBL{'fld'}{'weak'}{$array} = 1;
            push(@{$GBL{'fld'}{'regen'}{'weak'}}, $array);
        }

        # Deep cloning field
        elsif ($attr =~ /^Deep$/i) {
            $GBL{'fld'}{'deep'}{$array} = 1;
            push(@{$GBL{'fld'}{'regen'}{'deep'}}, $array);
        }

        # Defaults
        elsif ($attr =~ /^Def(?:ault)?[(]($BALANCED_PARENS)[)]$/i) {
            my $val;
            eval "package $pkg; use $]; \$val = sub { my \$self = \$_[0]; $1 }";
            if ($@) {
                OIO::Attribute->die(
                    'location'  => [ $pkg, (caller(2))[1,2] ],
                    'message'   => "Bad ':Default' attribute in package '$pkg'",
                    'Attribute' => $attr,
                    'Error'     => $@);
            }
            push(@{$GBL{'fld'}{'def'}{$pkg}}, [ $array, $val ]);
        }

        # Sequentials
        elsif ($attr =~ /^Seq(?:uence)?(?:From)?[(]($BALANCED_PARENS)[)]$/i) {
            my $val = $1;
            eval qq{
                package $pkg;
                my \$next = $val;
                \$val = eval{ \$next->can('next') }
                        ? sub { \$next->next() }
                        : sub { \$next++ };
            };
            if ($@) {
                OIO::Attribute->die(
                    'location'  => [ $pkg, (caller(2))[1,2] ],
                    'message'   => "Bad ':SequenceFrom' attribute in package '$pkg'",
                    'Attribute' => $attr,
                    'Error'     => $@);
            }
            push(@{$GBL{'fld'}{'def'}{$pkg}}, [ $array, $val ]);
        }

        # Field name for dump
        elsif ($attr =~ /^Name\s*[(]\s*'?([^)'\s]+)'?\s*[)]/i) {
            $GBL{'dump'}{'fld'}{$pkg}{$1} = { fld => $array, src => 'Name' };
        }

        # Unhandled
        # (Must filter out ':shared' attribute due to Perl bug)
        elsif ($attr ne 'shared') {
            push(@unused_attrs, $attr);
        }
    }

    # If using Attribute::Handlers, send it any unused attributes
    if (@unused_attrs &&
        Attribute::Handlers::UNIVERSAL->can('MODIFY_ARRAY_ATTRIBUTES'))
    {
        return (Attribute::Handlers::UNIVERSAL::MODIFY_ARRAY_ATTRIBUTES($pkg, $array, @unused_attrs));
    }

    # Return any unused attributes
    return (@unused_attrs);
}


### Array-based Object Support ###

# Supplies an ID for an object being created in a class tree
# and reclaims IDs from destroyed objects
sub _ID :Sub
{
    return if $GBL{'term'};           # Ignore during global cleanup

    my ($class, $id) = @_;            # The object's class and id
    my $tree = $GBL{'sub'}{'id'}{$class}{'pkg'};


    # If class is sharing, then all ID tracking is done as though in thread 0,
    # else tracking is done per thread
    my $sharing = is_sharing($class);
    my $thread_id = ($sharing) ? 0 : $GBL{'tid'};

    # Save deleted IDs for later reuse
    my $reuse = $GBL{'id'}{'reuse'};
    if ($id) {
        if (! exists($$reuse{$tree})) {
            $$reuse{$tree} = ($sharing) ? make_shared([]) : [];
        }
        lock($$reuse{$tree}) if $sharing;
        my $r_tree = $$reuse{$tree};
        if (! defined($$r_tree[$thread_id])) {
            $$r_tree[$thread_id] = ($sharing) ? make_shared([]) : [];
        } else {
            foreach  (@{$$r_tree[$thread_id]}) {
                if ($_ == $id) {
                    warn("ERROR: Duplicate reclaimed object ID ($id) in class tree for $tree in thread $thread_id\n");
                    return;
                }
            }
        }
        push(@{$$r_tree[$thread_id]}, $id);
        return;
    }

    # Use a reclaimed ID if available
    if (exists($$reuse{$tree})) {
        lock($$reuse{$tree}) if $sharing;
        if (defined($$reuse{$tree}[$thread_id])) {
            my $id = pop(@{$$reuse{$tree}[$thread_id]});
            if (defined($id)) {
                return $id;
            }
        }
    }

    # Return the next ID
    my $g_id = $GBL{'id'}{'obj'};
    if (exists($$g_id{$tree})) {
        lock($$g_id{$tree}) if $sharing;
        return (++$$g_id{$tree}[$thread_id]);
    }
    if ($sharing) {
        $$g_id{$tree} = make_shared([]);
        lock($$g_id{$tree});
        return (++$$g_id{$tree}[$thread_id]);
    }
    $$g_id{$tree} = [];
    return (++$$g_id{$tree}[$thread_id]);
}


### Initialization Handling ###

# Finds a subroutine's name from its code ref
sub sub_name :Sub(Private)
{
    my ($ref, $attr, $location) = @_;

    my $name;
    eval { $name = B::svref_2object($ref)->GV()->NAME(); };
    if ($@) {
        OIO::Attribute->die(
            'location' => $location,
            'message'  => "Failure finding name for subroutine with $attr attribute",
            'Error'    => $@);

    } elsif ($name eq '__ANON__') {
        OIO::Attribute->die(
            'location' => $location,
            'message'  => q/Subroutine name not found/,
            'Info'     => "Can't use anonymous subroutine for $attr attribute");
    }

    return ($name);   # Found
}


# Perform much of the 'magic' for this module
sub initialize :Sub(Private)
{
    return if (! delete($GBL{'init'}));

    my $trees = $GBL{'tree'}{'td'};
    my $id_subs = $GBL{'sub'}{'id'};
    my $obj_ids = $GBL{'id'}{'obj'};

    no warnings 'redefine';
    no strict 'refs';

    # Determine classes that need ID subs
    # Purge existing references to the default ID sub (i.e., _ID)
    #   if no objects exist in that hierarchy
    my %need_id_sub;
    foreach my $class (keys(%{$trees})) {
        if (! exists($$id_subs{$class})) {
            $need_id_sub{$class} = undef;
        } elsif (($$id_subs{$class}{'code'} == \&_ID) &&
                 ! exists($$obj_ids{$$id_subs{$class}{'pkg'}}))
        {
            delete($$id_subs{$class});
            $need_id_sub{$class} = undef;
        }
    }

    # Get ID subs to propagate
    my %to_propagate;
    foreach my $class (keys(%{$id_subs})) {
        $to_propagate{$$id_subs{$class}{'pkg'}} = undef;
    }

    # Propagate ID subs to classes
    while (%need_id_sub) {
        # Get ID sub package
        my $pkg;
        if (%to_propagate) {
            ($pkg) = keys(%to_propagate);
            delete($to_propagate{$pkg});
        } else {
            (my $class) = keys(%need_id_sub);
            $pkg = $$trees{$class}[0];
            delete($need_id_sub{$pkg});
            if (! defined($pkg)) {
                # bug
                OIO::Internal->die(
                    'message' => "Class '$class' has empty tree",
                );
            }
            if (exists($$id_subs{$pkg})) {
                # bug
                OIO::Internal->die(
                    'message' => "ID sub for '$pkg' exists but was not propagated properly",
                );
            }
            $$id_subs{$pkg} = {
                pkg  => $pkg,
                code => \&_ID,
                loc  => [ '', 'Default :ID sub', 0 ],
            };
        }

        # Add ID sub to classes using package
        next if (! exists($GBL{'asi'}{$pkg}));
        my @propagate_to = keys(%{$GBL{'asi'}{$pkg}});
        my %seen = map { $_ => undef } @propagate_to;
        while (my $class = pop(@propagate_to)) {
            if (exists($$id_subs{$class})) {
                # Verify it's the same ID sub
                if (($$id_subs{$class}{'code'} != $$id_subs{$pkg}{'code'}) ||
                    ($$id_subs{$class}{'pkg'}  ne $$id_subs{$pkg}{'pkg'}))
                {
                    # Runtime merging of hierarchies with existing objects
                    if (($$id_subs{$class}{'code'} == \&_ID) ||
                        ($$id_subs{$pkg}{'code'} == \&_ID))
                    {
                        OIO::Runtime->die(
                            'message' => "Possible extant objects prevent runtime creation of hierarchy for class '$class'",
                            'Info'    => "Runtime loading of classes needs to be performed before any objects are created within their hierarchies",
                            ((($$id_subs{$class}{'code'} == \&_ID) && ($$id_subs{$pkg}{'code'} == \&_ID))
                                ? ()
                                : ('Class1'  => "The hierarchy for '$$id_subs{$class}{'pkg'}' is using object IDs generated by " .
                                                (($$id_subs{$class}{'code'} == \&_ID) ? 'Object::InsideOut' : 'a custom :ID subroutine'),
                                   'Class2'  => "The hierarchy for '$$id_subs{$pkg}{'pkg'}' is using object IDs generated by " .
                                                (($$id_subs{$pkg}{'code'} == \&_ID) ? 'Object::InsideOut' : 'a custom :ID subroutine'))));
                    }
                    # Multiple :ID subs in hierarchy
                    my (undef, $file,  $line)  = @{$$id_subs{$class}{'loc'}};
                    my (undef, $file2, $line2) = @{$$id_subs{$pkg}{'loc'}};
                    OIO::Attribute->die(
                        'message' => "Multiple :ID subs defined within hierarchy for class '$class'",
                        'Info'    => ":ID subs in class '$$id_subs{$class}{'pkg'}' (file '$file', line $line), and class '$$id_subs{$pkg}{'pkg'}' (file '$file2', line $line2)");
                }
            } else {
                # Add ID sub to class
                $$id_subs{$class} = $$id_subs{$pkg};
                delete($need_id_sub{$class});
                # Propagate to classes in this class's tree
                foreach my $add (@{$$trees{$class}}) {
                    if (! defined($seen{$add})) {
                        push(@propagate_to, $add);
                        $seen{$add} = undef;
                    }
                }
                # Propagate to classes that use this one
                if (exists($GBL{'asi'}{$class})) {
                    foreach my $add (keys(%{$GBL{'asi'}{$class}})) {
                        if (! defined($seen{$add})) {
                            push(@propagate_to, $add);
                            $seen{$add} = undef;
                        }
                    }
                }
            }
        }
    }

    if ($GBL{'share'}{'ok'}) {
        # If needed, process any thread object sharing flags
        my $sh_cl = $GBL{'share'}{'cl'};
        foreach my $flag_class (keys(%{$sh_cl})) {
            # Find the class in any class tree
            foreach my $tree (values(%{$trees})) {
                if (grep(/^$flag_class$/, @$tree)) {
                    # Check each class in the tree
                    foreach my $class (@$tree) {
                        if (exists($$sh_cl{$class})) {
                            # Check for sharing conflicts
                            if ($$sh_cl{$class}{'share'}
                                    != $$sh_cl{$flag_class}{'share'})
                            {
                                my ($pkg1, $pkg2)
                                        = ($$sh_cl{$flag_class}{'share'})
                                                ? ($flag_class, $class)
                                                : ($class, $flag_class);
                                my @loc  = ($pkg1,
                                            $$sh_cl{$pkg1}{'file'},
                                            $$sh_cl{$pkg1}{'line'});
                                OIO::Code->die(
                                    'location' => \@loc,
                                    'message'  => "Can't combine thread-sharing classes ($pkg1) with non-sharing classes ($pkg2) in the same class tree",
                                    'Info'     => "Class '$pkg1' was declared as sharing (file '$loc[1]' line $loc[2]), but class '$pkg2' was declared as non-sharing (file '$$sh_cl{$pkg2}{'file'}' line $$sh_cl{$pkg2}{'line'})");
                            }
                        } else {
                            # Add the sharing flag to this class
                            $$sh_cl{$class} = $$sh_cl{$flag_class};
                        }
                    }
                }
            }
            # Set up for obj ID sequences, and obj ID reuse
            #   for shared classes using _ID
            if ($$sh_cl{$flag_class}{'share'}) {
                my $reuse = $GBL{'id'}{'reuse'};
                if (exists($$id_subs{$flag_class}) &&
                    ($$id_subs{$flag_class}{'code'} == \&_ID))
                {
                    my $share_tree = $$id_subs{$flag_class}{'pkg'};
                    if (! exists($$obj_ids{$share_tree})) {
                        $$obj_ids{$share_tree} = make_shared([]);
                        $$obj_ids{$share_tree}[0] = 0;
                    }
                    if (! exists($$reuse{$share_tree})) {
                        $$reuse{$share_tree} = make_shared([]);
                    }
                    my $r_tree = $$reuse{$share_tree};
                    if (! defined($$r_tree[0])) {
                        $$r_tree[0] = make_shared([]);
                    }
                }
            }
        }

        # Set up for shared object tracking
        if (! exists($GBL{'share'}{'obj'}) &&
            (($] < 5.008009) || ($threads::shared::VERSION lt '1.15')))
        {
            $GBL{'share'}{'obj'} = make_shared({});
        }
    }

    # Process field attributes
    process_fields();

    # Implement ->isa()/->can() with :AutoMethods
    if (%{$GBL{'sub'}{'auto'}}) {
        install_UNIVERSAL();
    }

    # Implement overload (-ify) operators
    if (exists($GBL{'sub'}{'ol'})) {
        generate_OVERLOAD(\%GBL);
    }

    # Add metadata for methods
    my $meta = $GBL{'meta'}{'add'};
    if (my $meta_m = delete($GBL{'meta'}{'method'})) {
        while (my $info = shift(@{$meta_m})) {
            $$info{'name'} ||= sub_name($$info{'code'}, ':METHOD', $$info{'loc'});
            $$meta{$$info{'pkg'}}{$$info{'name'}}{'kind'} = $$info{'kind'};
        }
    }

    # Add metadata for subroutines
    if (my $meta_s = delete($GBL{'meta'}{'subr'})) {
        while (my $info = shift(@{$meta_s})) {
            $$info{'name'} ||= sub_name($$info{'code'}, ':SUB', $$info{'loc'});
            $$meta{$$info{'pkg'}}{$$info{'name'}}{'hidden'} = 1;
        }
    }

    # Implement merged argument methods
    if (my $merge = delete($GBL{'merge'})) {
        while (my $info = shift(@{$merge})) {
            $$info{'name'} ||= sub_name($$info{'code'}, ':MergeArgs', $$info{'loc'});
            my $pkg = $$info{'pkg'};
            my $name = $$info{'name'};

            my $new_wrap = wrap_MERGE_ARGS($$info{'wrap'});
            *{$pkg.'::'.$name} = $new_wrap;
            $$info{'wrap'} = $new_wrap;

            $$meta{$pkg}{$name}{'merge_args'} = 1;
        }
    }

    # Implement restricted methods - only callable within hierarchy
    if (my $restr = delete($GBL{'perm'}{'restr'})) {
        while (my $info = shift(@{$restr})) {
            $$info{'name'} ||= sub_name($$info{'code'}, ':RESTRICTED', $$info{'loc'});
            my $pkg = $$info{'pkg'};
            my $name = $$info{'name'};

            my $exempt = [ grep {$_} split(/[,'\s]+/, $$info{'exempt'} || '') ];

            my $new_wrap = wrap_RESTRICTED($pkg, $name, $$info{'wrap'}, $exempt);
            *{$pkg.'::'.$name} = $new_wrap;
            $$info{'wrap'} = $new_wrap;

            $$meta{$pkg}{$name}{'restricted'} = 1;
        }
    }

    # Implement private methods - only callable from class itself
    if (my $priv = delete($GBL{'perm'}{'priv'})) {
        while (my $info = shift(@{$priv})) {
            $$info{'name'} ||= sub_name($$info{'code'}, ':PRIVATE', $$info{'loc'});
            my $pkg = $$info{'pkg'};
            my $name = $$info{'name'};

            my $exempt = [ $pkg, grep {$_} split(/[,'\s]+/, $$info{'exempt'} || '') ];

            my $new_wrap = wrap_PRIVATE($pkg, $name, $$info{'wrap'}, $exempt);
            *{$pkg.'::'.$name} = $new_wrap;
            $$info{'wrap'} = $new_wrap;

            $$meta{$pkg}{$name}{'private'} = 1;
        }
    }

    # Implement hidden methods - no longer callable by name
    if (my $hide = delete($GBL{'perm'}{'hide'})) {
        while (my $info = shift(@{$hide})) {
            $$info{'name'} ||= sub_name($$info{'code'}, ':HIDDEN', $$info{'loc'});
            my $pkg = $$info{'pkg'};
            my $name = $$info{'name'};

            *{$pkg.'::'.$name} = wrap_HIDDEN($pkg, $name);

            $$meta{$pkg}{$name}{'hidden'} = 1;
        }
    }

    # Implement cumulative methods
    if (exists($GBL{'sub'}{'cumu'}{'new'})) {
        generate_CUMULATIVE(\%GBL);
    }

    # Implement chained methods
    if (exists($GBL{'sub'}{'chain'}{'new'})) {
        generate_CHAINED(\%GBL);
    }

    # Export methods
    my @export = @{$GBL{'export'}};
    my $trees_bu = $GBL{'tree'}{'bu'};
    foreach my $pkg (keys(%{$trees})) {
        EXPORT:
        foreach my $sym (@export, ($pkg->isa('Storable'))
                                        ? (qw(STORABLE_freeze STORABLE_thaw))
                                        : ())
        {
            my $full_sym = $pkg.'::'.$sym;
            # Only export if method doesn't already exist,
            # and not overridden in a parent class
            if (! *{$full_sym}{CODE}) {
                foreach my $class (@{$$trees_bu{$pkg}}) {
                    my $class_sym = $class.'::'.$sym;
                    if (*{$class_sym}{CODE} &&
                        (*{$class_sym}{CODE} != \&{$sym}))
                    {
                        next EXPORT;
                    }
                }
                *{$full_sym} = \&{$sym};

                # Add metadata
                if ($sym eq 'new') {
                    $$meta{$pkg}{'new'} = { 'kind' => 'constructor',
                                            'merge_args' => 1 };

                } elsif ($sym eq 'clone' || $sym eq 'dump') {
                    $$meta{$pkg}{$sym}{'kind'} = 'object';

                } elsif ($sym eq 'create_field') {
                    $$meta{$pkg}{$sym}{'kind'} = 'class';

                } elsif ($sym =~ /^STORABLE_/ || ($sym eq 'AUTOLOAD')) {
                    $$meta{$pkg}{$sym}{'hidden'} = 1;

                } elsif ($sym =~ /herit/ || $sym eq 'set') {
                    $$meta{$pkg}{$sym} = { 'kind' => 'object',
                                           'restricted' => 1 };
                }
            }
        }
    }

    # Add accumulated metadata
    add_meta($meta);
    $GBL{'meta'}{'add'} = {};
}


# Process attributes for field hashes/arrays including generating accessors
sub process_fields :Sub(Private)
{
    my $new = delete($GBL{'fld'}{'new'});
    return if (! $new);

    # 'Want' module loaded?
    my $use_want = (defined($Want::VERSION) && ($Want::VERSION >= 0.12));

    my $trees    = $GBL{'tree'}{'td'};
    my $fld_refs = $GBL{'fld'}{'ref'};
    my $g_ho     = $GBL{'hash_only'};
    my $do_ho    = %{$g_ho};

    # Process field attributes
    foreach my $pkg (keys(%{$new})) {
        while (my $item = shift(@{$$new{$pkg}})) {
            my ($fld, $attr) = @{$item};

            # Verify not a 'hash field only' class
            if ((ref($fld) eq 'ARRAY') && $do_ho) {
                foreach my $ho (keys(%{$g_ho})) {
                    foreach my $class (@{$$trees{$pkg}}) {
                        if ($class eq $ho) {
                            my $loc = ((caller())[1] =~ /Dynamic/)
                                        ? [ (caller(2))[0..2] ]
                                        : $$g_ho{$ho};
                            OIO::Code->die(
                                'location' => $loc,
                                'message'  => "Can't combine 'hash only' classes ($ho) with array-based classes ($class) in the same class tree",
                                'Info'     => "Class '$ho' was declared as ':hash_only', but class '$class' has array-based fields");
                        }
                    }
                }
            }

            # Share the field, if applicable
            if (is_sharing($pkg) && !threads::shared::is_shared($fld)) {
                # Preserve any contents
                my $contents = Object::InsideOut::Util::clone_shared($fld);

                # Share the field
                threads::shared::share($fld);

                # Restore contents
                if ($contents) {
                    if (ref($fld) eq 'HASH') {
                        %{$fld} = %{$contents};
                    } else {
                        @{$fld} = @{$contents};
                    }
                }
            }

            # Process any accessor declarations
            if ($attr) {
                create_accessors($pkg, $fld, $attr, $use_want);
            }

            # Save field ref
            if (! grep { $_ == $fld } @{$$fld_refs{$pkg}}) {
                push(@{$$fld_refs{$pkg}}, $fld);
            }
        }
    }
}


# Normalize the :InitArgs hash
sub normalize :Sub
{
    my $hash = $_[$#_];
    if (ref($hash) ne 'HASH') {
        OIO::Args->die(
            'message' => 'Argument is not a hash ref',
            'Usage'   => q/Object::InsideOut::normalize($hash)/);
    }

    foreach my $arg (keys(%{$hash})) {
        my $spec = $$hash{$arg};
        next if (ref($spec) ne 'HASH');
        foreach my $opt (keys(%{$spec})) {
            if ($opt =~ qr/^DEF(?:AULTs?)?$/i) {
                $$spec{'_D'} = $$spec{$opt};
            } elsif ($opt =~ qr/^FIELD$/i) {
                $$spec{'_F'} = $$spec{$opt};
            } elsif ($opt =~ qr/^(?:MAND|REQ)/i) {
                $$spec{'_M'} = $$spec{$opt};
            } elsif ($opt =~ qr/^PRE/i) {
                $$spec{'_P'} = $$spec{$opt};
            } elsif ($opt =~ qr/^RE(?:GEXp?)?$/i) {
                # Turn into an actual 'Regexp', if needed
                $$spec{'_R'} = (ref($$spec{$opt}) eq 'Regexp')
                                    ? $$spec{$opt}
                                    : qr/^$$spec{$opt}$/;
            } elsif ($opt =~ qr/^TYPE$/i) {
                $$spec{'_T'} = $$spec{$opt};
            }
        }
    }
    $$hash{' '} = undef;

    return ($hash);
}


### Thread-Shared Object Support ###

# Set a class as thread-sharing
sub set_sharing :Sub(Private)
{
    my ($class, $sharing, $file, $line) = @_;
    $sharing = ($sharing) ? 1 : 0;

    my $sh_cl = $GBL{'share'}{'cl'};
    if (exists($$sh_cl{$class})) {
        if ($$sh_cl{$class}{'share'} != $sharing) {
            my (@loc, $nfile, $nline);
            if ($sharing) {
                @loc  = ($class, $file, $line);
                $nfile = $$sh_cl{$class}{'file'};
                $nline = $$sh_cl{$class}{'line'};
            } else {
                @loc  = ($class,
                         $$sh_cl{$class}{'file'},
                         $$sh_cl{$class}{'line'});
                ($nfile, $nline) = ($file, $line);
            }
            OIO::Code->die(
                'location' => \@loc,
                'message'  => "Can't combine thread-sharing and non-sharing instances of a class in the same application",
                'Info'     => "Class '$class' was declared as sharing in '$file' line $line, but was declared as non-sharing in '$nfile' line $nline");
        }
    } else {
        $$sh_cl{$class} = {
            share => $sharing,
            file  => $file,
            line  => $line,
        };
        # Set up equality via overload
        if ($sharing && $threads::shared::threads_shared
                     && $threads::shared::VERSION ge '0.95')
        {
            push(@{$GBL{'sub'}{'ol'}}, { 'pkg' => $class, 'ify' => 'EQUATE' });
        }
    }
}


# Determines if a class's objects are shared between threads
sub is_sharing :Sub(Private)
{
    return if ! $GBL{'share'}{'ok'};
    my $class = $_[0];
    my $sh_cl = $GBL{'share'}{'cl'};
    return (exists($$sh_cl{$class}) && $$sh_cl{$class}{'share'});
}


### Thread Cloning Support ###

sub CLONE
{
    # Don't execute when called for sub-classes
    return if ($_[0] ne 'Object::InsideOut');

    # Don't execute twice for same thread
    my $tid;
    if ($threads::threads) {
        $tid = threads->tid();
        return if ($GBL{'tid'} == $tid);
        $GBL{'tid'} = $tid;
    } else {
        # Pseudo-fork
        return if (exists($GBL{'pids'}{$$}));
        $GBL{'pids'}{$$} = undef;
        $tid = $GBL{'tid'};
    }

    # Check for delayed threads::shared usage
    if ($threads::shared::threads_shared && ! $GBL{'share'}{'ok'}) {
        OIO::Code->die(
            'message' => q/'threads::shared' imported after Object::InsideOut initialized/,
            'Info'    => q/Add 'use threads::shared;' to the start of your application code/);
    }

    # Process thread-shared objects
    if (exists($GBL{'share'}{'obj'})) {
        my $sh_obj = $GBL{'share'}{'obj'};
        lock($sh_obj);

        # Add thread ID to every object in the thread tracking registry
        foreach my $class (keys(%{$sh_obj})) {
            foreach my $oid (keys(%{$$sh_obj{$class}})) {
                push(@{$$sh_obj{$class}{$oid}}, $tid);
            }
        }
    }

    # Fix field references
    my $g_fld = $GBL{'fld'};
    my $regen = $$g_fld{'regen'};
    $$g_fld{'type'} = { map { $_->[0] => $_->[1] } @{$$regen{'type'}} };
    $$g_fld{'weak'} = { map { $_ => 1 } @{$$regen{'weak'}} };
    $$g_fld{'deep'} = { map { $_ => 1 } @{$$regen{'deep'}} };

    # Process non-thread-shared objects
    my $g_obj     = $GBL{'obj'};
    my $trees     = $GBL{'tree'}{'td'};
    my $id_subs   = $GBL{'sub'}{'id'};
    my $fld_ref   = $$g_fld{'ref'};
    my $weak      = $$g_fld{'weak'};
    my $repl_subs = $GBL{'sub'}{'repl'};
    my $do_repl   = keys(%{$repl_subs});
    foreach my $class (keys(%{$g_obj})) {
        my $obj_cl = $$g_obj{$class};

        # Get class tree
        my @tree = @{$$trees{$class}};

        # Get the ID sub for this class, if any
        my $id_sub = $$id_subs{$class}{'code'};

        # Get any replication handlers
        my @repl;
        if ($do_repl) {
            @repl = grep { $_ } map { $$repl_subs{$_} } @tree;
        }

        # Process each object in the class
        foreach my $old_id (keys(%{$obj_cl})) {
            my $obj;
            if ($id_sub == \&_ID) {
                # Objects using internal ID sub keep their same ID
                $obj = $$obj_cl{$old_id};

                # Set 'next object ID'
                my $pkg = $GBL{'sub'}{'id'}{$class}{'pkg'};
                my $g_id = $GBL{'id'}{'obj'}{$pkg};
                if (! $$g_id[$tid] || ($$g_id[$tid] < $$obj)) {
                    $$g_id[$tid] = $$obj;
                }

            } else {
                # Get cloned object associated with old ID
                $obj = delete($$obj_cl{$old_id});

                # Unlock the object
                Internals::SvREADONLY($$obj, 0) if ($] >= 5.008003);

                # Replace the old object ID with a new one
                local $SIG{'__DIE__'} = 'OIO::trap';
                $$obj = $id_sub->($class);

                # Lock the object again
                Internals::SvREADONLY($$obj, 1) if ($] >= 5.008003);

                # Update the keys of the field arrays/hashes
                # with the new object ID
                foreach my $pkg (@tree) {
                    foreach my $fld (@{$$fld_ref{$pkg}}) {
                        if (ref($fld) eq 'HASH') {
                            $$fld{$$obj} = delete($$fld{$old_id});
                            if ($$weak{'weak'}{$fld}) {
                                Scalar::Util::weaken($$fld{$$obj});
                            }
                        } else {
                            $$fld[$$obj] = $$fld[$old_id];
                            undef($$fld[$old_id]);
                            if ($$weak{$fld}) {
                                Scalar::Util::weaken($$fld[$$obj]);
                            }
                        }
                    }
                }

                # Resave weakened reference to object
                Scalar::Util::weaken($$obj_cl{$$obj} = $obj);
            }

            # Dispatch any special replication handling
            if (@repl) {
                my $pseudo_object = \do{ my $scalar = $old_id; };
                foreach my $repl (@repl) {
                    local $SIG{'__DIE__'} = 'OIO::trap';
                    $repl->($pseudo_object, $obj, 'CLONE');
                }
            }
        }
    }
}


### Object Methods ###

# Helper subroutine to create a new 'bare' object
sub _obj :Sub(Private)
{
    my $class = shift;

    # Create a new 'bare' object
    my $self = create_object($class, $GBL{'sub'}{'id'}{$class}{'code'});

    # Thread support
    if (is_sharing($class)) {
        threads::shared::share($self);

        # Add thread tracking list for this thread-shared object
        if (exists($GBL{'share'}{'obj'})) {
            my $sh_obj = $GBL{'share'}{'obj'};
            lock($sh_obj);
            if (exists($$sh_obj{$class})) {
                $$sh_obj{$class}{$$self} = make_shared([ $GBL{'tid'} ]);
            } else {
                $$sh_obj{$class} = make_shared({ $$self => [ $GBL{'tid'} ] });
            }
        }

    } elsif ($threads::threads) {
        # Add non-thread-shared object to thread cloning list
        Scalar::Util::weaken($GBL{'obj'}{$class}{$$self} = $self);
    }

    return ($self);
}


# Extracts specified args from those given
sub _args :Sub(Private)
{
    my ($class,
        $self,   # Object being initialized with args
        $spec,   # Hash ref of arg specifiers
        $args,   # Hash ref of args
        $used)   # Hash ref of used args
            = @_;

    # Ensure :InitArgs hash is normalized
    if (! exists($$spec{' '})) {
        normalize($spec);
    }

    # Extract arg-matching regexs from the specifiers
    my %regex;
    while (my ($key, $val) = each(%{$spec})) {
        next if ($key eq ' ');
        $regex{$key} = (ref($val) eq 'HASH') ? $$val{'_R'} : $val;
    }

    # Search for specified args
    my %found = ();
    my $add_used = $used;
    EXTRACT: {
        # Find arguments using regex's
        foreach my $key (keys(%regex)) {
            my $regex = $regex{$key};
            my ($value, $arg) = ($regex) ? hash_re($args, $regex) : ($$args{$key}, $key);
            if (defined($found{$key})) {
                if (defined($value)) {
                    $found{$key} = $value;
                }
            } else {
                $found{$key} = $value;
            }
            if (defined($arg)) {
                $$add_used{$arg} = undef;
            }
        }

        # Check for class-specific argument hash ref
        if (exists($$args{$class})) {
            $args = $$args{$class};
            if (ref($args) ne 'HASH') {
                OIO::Args->die(
                    'message' => "Bad class initializer for '$class'",
                    'Usage'   => q/Class initializers must be a hash ref/);
            }
            $$add_used{$class} = {};
            $add_used = $$add_used{$class};
            # Loop back to process class-specific arguments
            redo EXTRACT;
        }
    }

    # Check on what we've found
    CHECKIT:
    foreach my $key (keys(%{$spec})) {
        my $spec_item = $$spec{$key};
        # No specs to check
        if (ref($spec_item) ne 'HASH') {
            # The specifier entry was just 'key => regex'.  If 'key' is not in
            # the args, the we need to remove the 'undef' entry in the found
            # args hash.
            if (! defined($found{$key})) {
                delete($found{$key});
            }
            next CHECKIT;
        }

        # Preprocess the argument
        if (my $pre = $$spec_item{'_P'}) {
            if (ref($pre) ne 'CODE') {
                OIO::Code->die(
                    'message' => q/Can't handle argument/,
                    'Info'    => "'Preprocess' is not a code ref for initializer '$key' for class '$class'");
            }

            my (@errs);
            local $SIG{'__WARN__'} = sub { push(@errs, @_); };
            eval {
                local $SIG{'__DIE__'};
                $found{$key} = $pre->($class, $key, $spec_item, $self, $found{$key})
            };
            if ($@ || @errs) {
                my ($err) = split(/ at /, $@ || join(" | ", @errs));
                OIO::Code->die(
                    'message' => "Problem with preprocess routine for initializer '$key' for class '$class",
                    'Error'   => $err);
            }
        }

        # Handle args not found
        if (! defined($found{$key})) {
            # Complain if mandatory
            if ($$spec_item{'_M'}) {
                OIO::Args->die(
                    'message' => "Missing mandatory initializer '$key' for class '$class'");
            }

            # Assign default value
            if (exists($$spec_item{'_D'})) {
                if (ref($$spec_item{'_D'}) eq 'CODE') {
                    $found{$key} = $$spec_item{'_D'}->($self);
                } else {
                    $found{$key} = Object::InsideOut::Util::clone($$spec_item{'_D'});
                }
            }

            # If no default, then remove it from the found args hash
            if (! defined($found{$key})) {
                delete($found{$key});
                next CHECKIT;
            }
        }

        # Check for correct type
        if (my $type = $$spec_item{'_T'}) {
            my $subtype;

            # Custom type checking
            if (ref($type)) {
                if (ref($type) ne 'CODE') {
                    OIO::Code->die(
                        'message' => q/Can't validate argument/,
                        'Info'    => "'Type' is not a code ref or string for initializer '$key' for class '$class'");
                }

                my ($ok, @errs);
                local $SIG{'__WARN__'} = sub { push(@errs, @_); };
                eval {
                    local $SIG{'__DIE__'};
                    $ok = $type->($found{$key})
                };
                if ($@ || @errs) {
                    my ($err) = split(/ at /, $@ || join(" | ", @errs));
                    OIO::Code->die(
                        'message' => "Problem with type check routine for initializer '$key' for class '$class",
                        'Error'   => $err);
                }
                if (! $ok) {
                    OIO::Args->die(
                        'message' => "Initializer '$key' for class '$class' failed type check: $found{$key}");
                }
            }

            # Is it supposed to be a scalar
            elsif ($type =~ /^scalar$/i) {
                if (ref($found{$key})) {
                    OIO::Args->die(
                        'message' => "Bad value for initializer '$key': $found{$key}",
                        'Usage'   => "Initializer '$key' for class '$class' must be a scalar");
                }
            }

            # Is it supposed to be a number
            elsif ($type =~ /^num(?:ber|eric)?$/i) {
                if (! Scalar::Util::looks_like_number($found{$key})) {
                    OIO::Args->die(
                        'message' => "Bad value for initializer '$key': $found{$key}",
                        'Usage'   => "Initializer '$key' for class '$class' must be a number");
                }
            }

            # For 'LIST', turn anything not an array ref into an array ref
            elsif ($type =~ /^(?:list|array)\s*(?:\(\s*(\S+)\s*\))*$/i) {
                if (defined($1)) {
                    $subtype = $1;
                }
                if (ref($found{$key}) ne 'ARRAY') {
                    $found{$key} = [ $found{$key} ];
                }
            }

            # Otherwise, check for a specific class or ref type
            # Exact spelling and case required
            else {
                if ($type =~ /^(array|hash|scalar)(?:_?ref)?\s*(?:\(\s*(\S+)\s*\))*$/i) {
                    $type = uc($1);
                    if (defined($2)) {
                        $subtype = $2;
                    }
                }
                if (! is_it($found{$key}, $type)) {
                    OIO::Args->die(
                        'message' => "Bad value for initializer '$key': $found{$key}",
                        'Usage'   => "Initializer '$key' for class '$class' must be an object or ref of type '$type'");
                }
            }

            # Check type of each element in array
            if (defined($subtype)) {
                if ($subtype =~ /^scalar$/i) {
                    # Scalar elements
                    foreach my $elem (@{$found{$key}}) {
                        if (ref($elem)) {
                            OIO::Args->die(
                                'message' => "Bad value for initializer '$key': $elem",
                                'Usage'   => "Values making up initializer '$key' for class '$class' must be scalars");
                        }
                    }
                } elsif ($subtype =~ /^num(?:ber|eric)?$/i) {
                    # Numeric elements
                    foreach my $elem (@{$found{$key}}) {
                        if (! Scalar::Util::looks_like_number($elem)) {
                            OIO::Args->die(
                                'message' => "Bad value for initializer '$key': $elem",
                                'Usage'   => "Values making up initializer '$key' for class '$class' must be numeric");
                        }
                    }
                } else {
                    foreach my $elem (@{$found{$key}}) {
                        if (! is_it($elem, $subtype)) {
                            OIO::Args->die(
                                'message' => "Bad value for initializer '$key': $elem",
                                'Usage'   => "Values making up Initializer '$key' for class '$class' must be objects or refs of type '$subtype'");
                        }
                    }
                }
            }
        }

        # If the destination field is specified, then put it in, and remove it
        # from the found args hash.
        if (my $field = $$spec_item{'_F'}) {
            $self->set($field, delete($found{$key}));
        }
    }

    # Done - return remaining found args
    return (\%found);
}


# Object Constructor
sub new :MergeArgs
{
    my ($thing, $all_args) = @_;
    my $class = ref($thing) || $thing;

    # Can't call ->new() on this package
    if ($class eq 'Object::InsideOut') {
        OIO::Method->die('message' => q/'new' called on non-class 'Object::InsideOut'/);
    }

    # Perform package initialization, if required
    initialize();

    # Create a new 'bare' object
    my $self = _obj($class);

    # Object initialization activity caching
    my $have_cache = exists($GBL{'cache'}{$class});
    my %cache = ($have_cache) ? %{$GBL{'cache'}{$class}}
                              : ( 'pre'  => 0, 'def'  => 0 );

    # Execute pre-initialization subroutines
    if ($cache{'pre'} || ! $have_cache) {
        my $preinit_subs = $GBL{'sub'}{'pre'};
        if (%{$preinit_subs}) {
            foreach my $pkg (@{$GBL{'tree'}{'bu'}{$class}}) {
                if (my $preinit = $$preinit_subs{$pkg}) {
                    local $SIG{'__DIE__'} = 'OIO::trap';
                    $self->$preinit($all_args);
                    if ($have_cache) {
                        last if (! (--$cache{'pre'}));
                    } else {
                        $cache{'pre'}++;
                    }
                }
            }
        }
    }

    my $tree = $GBL{'tree'}{'td'}{$class};

    # Set any defaults
    if ($cache{'def'} || ! $have_cache) {
        foreach my $pkg (@{$tree}) {
            if (my $def = $GBL{'fld'}{'def'}{$pkg}) {
                $self->set($_->[0], $_->[1]->($self))
                    foreach (@{$def});
                if ($have_cache) {
                    last if (! (--$cache{'def'}));
                } else {
                    $cache{'def'}++;
                }
            }
        }
    }

    # Process :InitArgs
    my %pkg_args;
    my $used_args = {};
    my $g_args = $GBL{'args'};
    foreach my $pkg (@{$tree}) {
        if (my $spec = $$g_args{$pkg}) {
            $pkg_args{$pkg} = _args($pkg, $self, $spec, $all_args, $used_args);
        }
    }

    # Call :Init subs
    my $init_subs = $GBL{'sub'}{'init'};
    foreach my $pkg (@{$tree}) {
        if (my $init = $$init_subs{$pkg}) {
            local $SIG{'__DIE__'} = 'OIO::trap';
            if (exists($pkg_args{$pkg})) {
                $self->$init($pkg_args{$pkg});
            } else {
                $self->$init($all_args);
                undef($used_args);
            }

        } elsif (exists($pkg_args{$pkg})) {
            if (%{$pkg_args{$pkg}}) {
                # It's an error if there are unhandled args, but no :Init sub
                OIO::Args::Unhandled->die(
                    'message' => "Unhandled parameter for class '$class': " . join(', ', keys(%{$pkg_args{$pkg}})),
                    'Usage'   => q/Add appropriate 'Field =>' designators to the :InitArgs hash/);
            }

        } elsif (exists($$all_args{$pkg})) {
            # It's an error if there are unhandled class-specific args
            if (ref($$all_args{$pkg}) ne 'HASH') {
                OIO::Args->die(
                    'message' => "Bad class initializer for '$class'",
                    'Usage'   => q/Class initializers must be a hash ref/);
            }
            OIO::Args::Unhandled->die(
                'message' => "Unhandled parameter for class '$class': " . join(', ', keys(%{$$all_args{$pkg}})),
                'Usage'   => q/Add :Init subroutine or :InitArgs hash/);
        }
    }

    # Any unused args?
    if ($used_args) {
        my %pkgs;
        @pkgs{@{$tree}} = undef;
        foreach my $key (keys(%$all_args)) {
            if (exists($pkgs{$key})) {
                foreach my $subkey (keys(%{$$all_args{$key}})) {
                    if (! exists($$used_args{$key}{$subkey})) {
                        OIO::Args::Unhandled->die('message' => "Unhandled parameter for class '$key': $subkey");
                    }
                }
            } else {
                if (! exists($$used_args{$key})) {
                    OIO::Args::Unhandled->die('message' => "Unhandled parameter: $key");
                }
            }
        }
    }

    # Remember object initialization activity caching
    if (! $have_cache) {
        $GBL{'cache'}{$class} = \%cache;
    }

    # Done - return object
    return ($self);
}


# Creates a copy of an object
sub clone
{
    my ($parent, $is_deep) = @_;          # Parent object and deep cloning flag
    $is_deep = ($is_deep) ? 'deep' : '';  # Deep clone the object?

    # Must call ->clone() as an object method
    my $class = Scalar::Util::blessed($parent);
    if (! $class) {
        OIO::Method->die('message' => q/'clone' called as a class method/);
    }

    # Create a new 'bare' object
    my $clone = _obj($class);

    # Flag for shared class
    my $am_sharing = is_sharing($class);

    # Clone the object
    my $fld_ref = $GBL{'fld'}{'ref'};
    my $weak    = $GBL{'fld'}{'weak'};
    my $deep    = $GBL{'fld'}{'deep'};
    my $repl    = $GBL{'sub'}{'repl'};
    foreach my $pkg (@{$GBL{'tree'}{'td'}{$class}}) {
        # Clone field data from the parent
        foreach my $fld (@{$$fld_ref{$pkg}}) {
            my $fdeep = $is_deep || $$deep{$fld};  # Deep clone the field?
            lock($fld) if ($am_sharing);
            if (ref($fld) eq 'HASH') {
                $$fld{$$clone} = (! $fdeep) ? $$fld{$$parent}
                               : ($am_sharing)
                                    ? Object::InsideOut::Util::clone_shared($$fld{$$parent})
                                    : Object::InsideOut::Util::clone($$fld{$$parent});
                if ($$weak{$fld}) {
                    Scalar::Util::weaken($$fld{$$clone});
                }
            } else {
                $$fld[$$clone] = (! $fdeep) ? $$fld[$$parent]
                               : ($am_sharing)
                                    ? Object::InsideOut::Util::clone_shared($$fld[$$parent])
                                    : Object::InsideOut::Util::clone($$fld[$$parent]);
                if ($$weak{$fld}) {
                    Scalar::Util::weaken($$fld[$$clone]);
                }
            }
        }

        # Dispatch any special replication handling
        if (my $replicate = $$repl{$pkg}) {
            local $SIG{'__DIE__'} = 'OIO::trap';
            $parent->$replicate($clone, $is_deep);
        }
    }

    # Done - return clone
    return ($clone);
}


# Get a metadata object
sub meta
{
    my $class = ref($_[0]) || $_[0];

    # No metadata for OIO
    if ($class eq 'Object::InsideOut') {
        OIO::Method->die('message' => q/'meta' called on non-class 'Object::InsideOut'/);
    }

    initialize();   # Perform package initialization, if required

    return (Object::InsideOut::Metadata->new('GBL'   => \%GBL,
                                             'CLASS' => $class));
}


# Put data in a field, making sure that sharing is supported
sub set
{
    my ($self, $field, $data) = @_;

    # Must call ->set() as an object method
    if (! Scalar::Util::blessed($self)) {
        OIO::Method->die('message' => q/'set' called as a class method/);
    }

    # Restrict usage to inside class hierarchy
    if (! $self->isa('Object::InsideOut')) {
        my $caller = caller();
        OIO::Method->die('message' => "Can't call restricted method 'inherit' from class '$caller'");
    }

    # Check usage
    if (! defined($field)) {
        OIO::Args->die(
            'message'  => 'Missing field argument',
            'Usage'    => '$obj->set($field_ref, $data)');
    }
    my $fld_type = ref($field);
    if (! $fld_type || ($fld_type ne 'ARRAY' && $fld_type ne 'HASH')) {
        OIO::Args->die(
            'message' => 'Invalid field argument',
            'Usage'   => '$obj->set($field_ref, $data)');
    }

    # Check data
    my $weak = $GBL{'fld'}{'weak'}{$field};
    if ($weak && ! ref($data)) {
        OIO::Args->die(
            'message'  => "Bad argument: $data",
            'Usage'    => q/Argument to specified field must be a reference/);
    }

    # Handle sharing
    if ($GBL{'share'}{'ok'} && threads::shared::is_shared($field)) {
        lock($field);
        if ($fld_type eq 'HASH') {
            $$field{$$self} = make_shared($data);
        } else {
            $$field[$$self] = make_shared($data);
        }

    } else {
        # No sharing - just store the data
        if ($fld_type eq 'HASH') {
            $$field{$$self} = $data;
        } else {
            $$field[$$self] = $data;
        }
    }

    # Weaken data, if required
    if ($weak) {
        if ($fld_type eq 'HASH') {
            Scalar::Util::weaken($$field{$$self});
        } else {
            Scalar::Util::weaken($$field[$$self]);
        }
    }
}


# Object Destructor
sub DESTROY
{
    my $self  = shift;
    my $class = ref($self);

    return if (! $$self);

    # Grab any error coming into this routine
    my $err = $@;

    # Preserve other error variables
    local($!, $^E, $?);

    # Workaround for Perl's "in cleanup" bug
    if ($threads::shared::threads_shared && ! $GBL{'term'}) {
        eval {
            my $bug = keys(%{$GBL{'id'}{'obj'}})
                    + keys(%{$GBL{'id'}{'reuse'}})
                    + ((exists($GBL{'share'}{'obj'}))
                        ? keys(%{$GBL{'share'}{'obj'}})
                        : 0);
        };
        if ($@) {
            $GBL{'term'} = 1;
        }
    }

    eval {
        my $is_sharing = is_sharing($class);
        if ($is_sharing) {
            # Thread-shared object
            my $tid = $GBL{'tid'};

            if ($GBL{'term'}) {
                return if ($tid);   # Continue only if main thread

            } elsif (exists($GBL{'share'}{'obj'})) {
                my $so_cl = $GBL{'share'}{'obj'}{$class};
                if (! exists($$so_cl{$$self})) {
                    # This can happen when a non-shared object
                    #   is returned from a thread
                    warn("ERROR: Attempt to DESTROY object ID $$self of class $class in thread ID $tid twice\n");
                    return;
                }

                # Remove thread ID from this object's thread tracking list
                # NOTE:  The threads->object() test was added for the case
                # where OIO objects are passed via Thead::Queue.  I don't
                # know if this will cause problems with detached threads as
                # threads->object() returns undef for them.  Also, the main
                # thread (0) is always a valid thread.
                lock($so_cl);
                if (@{$$so_cl{$$self}} = grep { ($_ != $tid) &&
                                                (($_ == 0) || threads->object($_)) }
                                            @{$$so_cl{$$self}}) {
                    return;
                }

                # Delete the object from the thread tracking registry
                delete($$so_cl{$$self});
            }

        } elsif ($threads::threads) {
            my $obj_cl = $GBL{'obj'}{$class};
            if (! exists($$obj_cl{$$self})) {
                warn("ERROR: Attempt to DESTROY object ID $$self of class $class twice\n");
                return;
            }

            # Delete this non-thread-shared object from the thread cloning
            # registry
            delete($$obj_cl{$$self});
        }

        # Dispatch any special destruction handling
        my $dest_err;
        my $dest_subs = $GBL{'sub'}{'dest'};
        my $fld_refs  = $GBL{'fld'}{'ref'};
        foreach my $pkg (@{$GBL{'tree'}{'bu'}{$class}}) {
            if (my $destroy = $$dest_subs{$pkg}) {
                eval {
                    local $SIG{'__DIE__'} = 'OIO::trap';
                    $self->$destroy();
                };
                $dest_err = OIO::combine($dest_err, $@);
            }
        }

        # Delete object field data
        foreach my $pkg (@{$GBL{'tree'}{'bu'}{$class}}) {
            foreach my $fld (@{$$fld_refs{$pkg}}) {
                # If sharing, then must lock object field
                lock($fld) if ($is_sharing);
                if (ref($fld) eq 'HASH') {
                    if ($is_sharing) {
                        # Workaround for Perl's "in cleanup" bug
                        next if ! defined($$fld{$$self});
                    }
                    delete($$fld{$$self});
                } else {
                    if ($is_sharing) {
                        # Workaround for Perl's "in cleanup" bug
                        next if ! defined($$fld[$$self]);
                    }
                    undef($$fld[$$self]);
                }
            }
        }

        # Unlock the object
        Internals::SvREADONLY($$self, 0) if ($] >= 5.008003);

        # Reclaim the object ID if applicable
        if ($GBL{'sub'}{'id'}{$class}{'code'} == \&_ID) {
            _ID($class, $$self);
        }

        # Erase the object ID - just in case
        $$self = undef;

        # Propagate any errors
        if ($dest_err) {
            die($dest_err);
        }
    };

    # Propagate any errors
    if ($err || $@) {
        $@ = OIO::combine($err, $@);
        die("$@") if (! $err);
    }
}


# OIO specific ->can()
sub can :Method(Object)
{
    my ($thing, $method) = @_;

    return if (! defined($thing));

    # Metadata call for methods
    if (@_ == 1) {
        my $meths = Object::InsideOut::meta($thing)->get_methods();
        return (wantarray()) ? (keys(%$meths)) : [ keys(%$meths) ];
    }

    return if (! defined($method));

    # Try UNIVERSAL::can()
    eval { $thing->Object::InsideOut::SUPER::can($method) };
}


# OIO specific ->isa()
sub isa :Method(Object)
{
    my ($thing, $type) = @_;

    return ('') if (! defined($thing));

    # Metadata call for classes
    if (@_ == 1) {
        return Object::InsideOut::meta($thing)->get_classes();
    }

    # Workaround for Perl bug #47233
    return ('') if (! defined($type));

    # Try UNIVERSAL::isa()
    eval { $thing->Object::InsideOut::SUPER::isa($type); }
}


### Serialization Support Using Storable ###

sub STORABLE_freeze :Sub
{
    my ($self, $cloning) = @_;
    return ('', $self->dump());
}

sub STORABLE_thaw :Sub
{
    my ($obj, $cloning, $data);
    if (@_ == 4) {
        ($obj, $cloning, undef, $data) = @_;
    } else {
        # Backward compatibility
        ($obj, $cloning, $data) = @_;
    }

    # Recreate the object
    my $self;
    eval {
        $self = Object::InsideOut->pump($data);
    };
    if ($@) {
        die($@->as_string());   # Storable doesn't like exception objects
    }

    # Transfer the ID to Storable's object
    $$obj = $$self;
    # Make object shared, if applicable
    if (is_sharing(ref($obj))) {
        threads::shared::share($obj);
    }
    # Make object readonly
    if ($] >= 5.008003) {
        Internals::SvREADONLY($$obj, 1);
        Internals::SvREADONLY($$self, 0);
    }
    # Prevent object destruction
    undef($$self);
}


### Accessor Generator ###

# Names a field for dumping
sub add_dump_field :Sub(Private)
{
    my ($src, $name, $fld, $dump) = @_;

    # Name already in use for different field
    if (exists($$dump{$name}) && ($fld != $$dump{$name}{'fld'})) {
        return ('conflict');
    }

    # Entry already exists for field
    if (my ($old_name) = grep { $$dump{$_}{'fld'} == $fld } keys(%$dump)) {
        my $old_src = $$dump{$old_name}{'src'};
        if ($old_src eq 'Name') {
            return ('named');
        } elsif ($src eq 'Name') {
            delete($$dump{$old_name});
        } elsif ($old_src eq 'InitArgs') {
            return ('named');
        } elsif ($src eq 'InitArgs') {
            delete($$dump{$old_name});
        } elsif ($old_src eq 'Get') {
            return ('named');
        } elsif ($src eq 'Get') {
            delete($$dump{$old_name});
        } elsif ($old_src eq 'Set') {
            return ('named');
        } else {
            delete($$dump{$old_name});    # Shouldn't get here
        }
    }

    $$dump{$name} = { fld => $fld, src => $src };
    return ('okay');
}


# Utility sub to infer class API from symbol table...
# (replaces ->meta->get_methods for non-OIO classes)
sub get_symtab_methods_for :Sub(Private)
{
    my ($class_delegated_to) = @_;

    my %methods;   #...collects the methods that are found

    # Walk the class's inheritance tree...
    my @hierarchy = ($class_delegated_to);
    while (my $classname = shift @hierarchy) {
        no strict 'refs'; #...because symbols are inherently symbolic

        # Accumulate ancestors for subsequent investigation...
        push(@hierarchy, @{$classname.'::ISA'});

        # Grab and remember all subs from this class's symbol table...
        for my $symname (keys(%{$classname.'::'})) {
            # Only want symbols that define subroutines...
            next if !*{$classname.'::'.$symname}{CODE};
            # Save the necessary info...
            $methods{$symname}{'class'} = $class_delegated_to;
        }
    }

    return \%methods
}


# Utility sub to handle :Handles(Class::*) feature...
sub get_class_methods :Sub(Private)
{
    my ($class_delegated_from, $class_delegated_to) = @_;

    # Not expandable...
    return $class_delegated_to if $class_delegated_to !~ /::/;

    # Clean up any trailing ::...
    $class_delegated_to =~ s/::+$//;

    # Grab all known method names of specified class...
    my $methods = $class_delegated_to->can('meta')
                        ? $class_delegated_to->meta()->get_methods()
                        : get_symtab_methods_for($class_delegated_to);

    # Select the "real" ones...
    no strict 'refs';
    return grep {
        # Ignore "infrastructure" methods...
        !/^(?:new|clone|meta|set)$/

        # Ignore Object::InsideOut internal methods...
        && $methods->{$_}{class} eq $class_delegated_to

        # Ignore methods already installed...
        && !*{"${class_delegated_from}::$_"}{CODE}

    } keys %{$methods};
}


# Creates object data accessors for classes
sub create_accessors :Sub(Private)
{
    my ($pkg, $field_ref, $attr, $use_want) = @_;

    # Extract info from attribute
    my ($kind) = $attr =~ /^(\w+)/;
    my ($name) = $attr =~ /^\w+\s*\(\s*'?([\w:()]*)'?\s*\)$/;
    my ($decl) = $attr =~ /^\w+\s*\(\s*(.*)\s*\)/;
    my $type_code;

    if ($name) {
        $decl = "{'$kind'=>'$name'}";
        undef($name);
    } elsif (! $decl) {
        return if ($kind =~ /^Field/i);
        OIO::Attribute->die(
            'message'   => "Missing declarations for attribute in package '$pkg'",
            'Attribute' => $attr);
    } elsif (($kind =~ /^Type/i) && ($decl =~ /^(?:sub|\\&)/)) {
        $type_code = $decl;
        $decl = "{'$kind'=>$decl}";
    } elsif ($kind =~ /^Hand/i) {
        $decl =~ s/['",]/ /g;
        $decl = "{'$kind'=>'$decl'}";
    } elsif ($kind !~ /^Field/i) {
        if (! ($decl =~ s/'?name'?\s*=>/'$kind'=>/i)) {
            OIO::Attribute->die(
                'message'   => "Missing 'Name' parameter for attribute in package '$pkg'",
                'Attribute' => $attr);
        }
    }

    # Parse the accessor declaration
    my $acc_spec;
    {
        # Ensure the attribute declaration is a hash
        if ($decl !~ /^{/) {
            $decl = "{ $decl }";
        }

        my @errs;
        local $SIG{'__WARN__'} = sub { push(@errs, @_); };

        eval "package $pkg; use $]; \$acc_spec = $decl";

        if ($@ || @errs) {
            my ($err) = split(/ at /, $@ || join(" | ", @errs));
            OIO::Attribute->die(
                'message'   => "Malformed attribute in package '$pkg'",
                'Error'     => $err,
                'Attribute' => $attr);
        }
    }

    my $fld_type = $GBL{'fld'}{'type'};

    # Get info for accessors/delegators
    my ($get, $set, $return, $private, $restricted, $lvalue, $arg, $pre, $delegate);
    my $accessor_type = 'accessor';
    if ($kind !~ /^arg$/i) {
        foreach my $key (keys(%{$acc_spec})) {
            my $key_uc = uc($key);
            my $val = $$acc_spec{$key};

            # :InitArgs
            if ($key_uc =~ /ALL/) {
                $arg = $val;
                if ($key_uc eq 'ALL') {
                    $key_uc = 'ACC';
                }
            } elsif ($key_uc =~ /R(?:EAD)?O(?:NLY)?/) {
                $arg = $val;
                if ($key_uc =~ /^R(?:EAD)?O(?:NLY)?$/) {
                    $key_uc = 'GET';
                }
            } elsif ($key_uc =~ /ARG/) {
                $arg = $val;
                $key_uc = 'IGNORE';
            }

            # Standard accessors
            if ($key_uc =~ /^ST.*D.*R(?:EAD)?O(?:NLY)?/) {
                $get = 'get_' . $val;
            }
            elsif ($key_uc =~ /^ST.*D/) {
                $get = 'get_' . $val;
                $set = 'set_' . $val;
            }
            # Get and/or set accessors
            elsif ($key_uc =~ /^ACC|^COM|^MUT|[GS]ET/) {
                # Get accessor
                if ($key_uc =~ /ACC|COM|MUT|GET/) {
                    $get = $val;
                }
                # Set accessor
                if ($key_uc =~ /ACC|COM|MUT|SET/) {
                    $set = $val;
                }
            }
            # Deep clone the field
            elsif ($key_uc eq 'COPY' || $key_uc eq 'CLONE') {
                if (uc($val) eq 'DEEP') {
                    $GBL{'fld'}{'deep'}{$field_ref} = 1;
                }
                next;
            } elsif ($key_uc eq 'DEEP') {
                if ($val) {
                    $GBL{'fld'}{'deep'}{$field_ref} = 1;
                }
                next;
            }
            # Store weakened refs
            elsif ($key_uc =~ /^WEAK/) {
                if ($val) {
                    $GBL{'fld'}{'weak'}{$field_ref} = 1;
                }
                next;
            }
            # Field type checking for set accessor
            elsif ($key_uc eq 'TYPE') {
                # Check type-checking setting and set default
                if (!$val || (ref($val) && (ref($val) ne 'CODE'))) {
                    OIO::Attribute->die(
                        'message'   => "Can't create accessor method for package '$pkg'",
                        'Info'      => q/Bad 'Type' specifier: Must be a 'string' or code ref/,
                        'Attribute' => $attr);
                }
                # Normalize type declaration
                if (! ref($val)) {
                    $val =~ s/\s//g;
                    my $subtype;
                    if ($val =~ /^(.*)\((.+)\)$/i) {
                        $val = $1;
                        $subtype = $2;
                        if ($subtype =~ /^num(?:ber|eric)?$/i) {
                            $subtype = 'numeric';
                        } elsif ($subtype =~ /^scalar$/i) {
                            $subtype = 'scalar';
                        }
                    }
                    if ($val =~ /^num(?:ber|eric)?$/i) {
                        $val = 'numeric';
                    } elsif ($val =~ /^scalar$/i) {
                        $val = 'scalar';
                    } elsif ($val =~ /^(?:list|array)$/i) {
                        $val = 'list';
                    } elsif (uc($val) eq 'HASH') {
                        $val = 'HASH';
                    } elsif ($val =~ /^(hash|array|scalar)_?ref$/i) {
                        $val = uc($1) . '_ref';
                    }
                    if ($subtype) {
                        $val .= "($subtype)";
                    }
                }
                my $type = {
                    type => $val,
                    code => $type_code,
                };
                $$fld_type{$field_ref} = $type;
                push(@{$GBL{'fld'}{'regen'}{'type'}}, [ $field_ref, $type ]);
                next;
            }
            # Field name for ->dump()
            elsif ($key_uc eq 'NAME') {
                $name = $val;
            }
            # Set accessor return type
            elsif ($key_uc =~ /^RET(?:URN)?$/) {
                $return = uc($val);
            }
            # Set accessor permission
            elsif ($key_uc =~ /^PERM|^PRIV|^REST/) {
                if ($key_uc =~ /^PERM/) {
                    if ($val =~ /^PRIV/i) {
                        my @exempt = split(/[(),\s]+/, $val);
                        @exempt = grep { $_ } @exempt;
                        shift(@exempt);
                        unshift(@exempt, $pkg);
                        $private = "'" . join("','", @exempt) . "'";
                    } elsif ($val =~ /^REST/i) {
                        my @exempt = split(/[(),\s]+/, $val);
                        @exempt = grep { $_ } @exempt;
                        shift(@exempt);
                        $restricted = "'" . join("','", @exempt) . "'";
                    }
                } elsif ($key_uc =~ /^PRIV/) {
                    if ($val) {
                        $private = "'$pkg'";
                    }
                } elsif ($key_uc =~ /^REST/) {
                    if ($val) {
                        $restricted = '';
                    }
                }
            }
            # :lvalue accessor
            elsif ($key_uc =~ /^LV/) {
                if ($val && !Scalar::Util::looks_like_number($val)) {
                    $get = $val;
                    $set = $val;
                    $lvalue = 1;
                } else {
                    $lvalue = $val;
                }
            }
            # Preprocessor
            elsif ($key_uc =~ /^PRE/) {
                $pre = $val;
                if (ref($pre) ne 'CODE') {
                    OIO::Attribute->die(
                        'message'   => "Can't create accessor method for package '$pkg'",
                        'Info'      => q/Bad 'Preprocessor' specifier: Must be a code ref/,
                        'Attribute' => $attr);
                }
            }
            # Delegator
            elsif ($key_uc =~ /^HAND/) {
                $delegate = $val;
                $accessor_type = 'delegator';
            }
            # Unknown parameter
            elsif ($key_uc ne 'IGNORE') {
                OIO::Attribute->die(
                    'message' => "Can't create accessor method for package '$pkg'",
                    'Info'    => "Unknown accessor specifier: $key");
            }

            # $val must have a usable value
            if (! defined($val) || $val eq '') {
                OIO::Attribute->die(
                    'message'   => "Invalid '$key' entry in attribute",
                    'Attribute' => $attr);
            }
        }
    }

    # :InitArgs
    if ($arg || ($kind =~ /^ARG$/i)) {
        my $g_args = $GBL{'args'};
        if (! exists($$g_args{$pkg})) {
            $$g_args{$pkg} = {};
        }
        $g_args = $$g_args{$pkg};
        if (!$arg) {
            $arg = hash_re($acc_spec, qr/^ARG$/i);
            $$g_args{$arg} = normalize($acc_spec);
        }
        if (!defined($name)) {
            $name = $arg;
        }
        $$g_args{$arg}{'_F'} = $field_ref;
        # Add type to :InitArgs
        if ($$fld_type{$field_ref} && ! exists($$g_args{$arg}{'_T'})) {
            $$g_args{$arg}{'_T'} = $$fld_type{$field_ref}{'type'};
        }

        # Add default to :InitArgs
        if (my $g_def = delete($GBL{'fld'}{'def'}{$pkg})) {
            my @defs;
            foreach my $item (@{$g_def}) {
                if ($field_ref == $$item[0]) {
                    $$g_args{$arg}{'_D'} = $$item[1];
                } else {
                    push(@defs, $item);
                }
            }
            if (@defs) {
                $GBL{'fld'}{'def'}{$pkg} = \@defs;
            }
        }
    }

    # Add field info for dump()
    my $dump = $GBL{'dump'}{'fld'};
    $$dump{$pkg} ||= {};
    $dump = $$dump{$pkg};

    if ($name) {
        if (add_dump_field('Name', $name, $field_ref, $dump) eq 'conflict') {
            OIO::Attribute->die(
                'message'   => "Can't create accessor method for package '$pkg'",
                'Info'      => "'$name' already specified for another field using '$$dump{$name}{'src'}'",
                'Attribute' => $attr);
        }
        # Done if only 'Name' present
        if (! $get && ! $set && ! $return && ! $lvalue) {
            return;
        }
    } elsif ($get) {
        if (add_dump_field('Get', $get, $field_ref, $dump) eq 'conflict') {
            OIO::Attribute->die(
                'message'   => "Can't create accessor method for package '$pkg'",
                'Info'      => "'$get' already specified for another field using '$$dump{$get}{'src'}'",
                'Attribute' => $attr);
        }
    } elsif ($set) {
        if (add_dump_field('Set', $set, $field_ref, $dump) eq 'conflict') {
            OIO::Attribute->die(
                'message'   => "Can't create accessor method for package '$pkg'",
                'Info'      => "'$set' already specified for another field using '$$dump{$set}{'src'}'",
                'Attribute' => $attr);
        }
    } elsif (! $return && ! $lvalue && ! $delegate) {
        return;
    }

    # If 'RETURN' or 'LVALUE', need 'SET', too
    if (($return || $lvalue) && ! $set) {
        OIO::Attribute->die(
            'message'   => "Can't create accessor method for package '$pkg'",
            'Info'      => "No set accessor specified to go with 'RETURN'/'LVALUE'",
            'Attribute' => $attr);
    }

    # Check for name conflict
    foreach my $method ($get, $set) {
        if ($method) {
            no strict 'refs';
            # Do not overwrite existing methods
            if (*{$pkg.'::'.$method}{CODE}) {
                OIO::Attribute->die(
                    'message'   => q/Can't create accessor method/,
                    'Info'      => "Method '$method' already exists in class '$pkg'",
                    'Attribute' => $attr);
            }
        }
    }

    # Check return type and set default
    if (! defined($return) || $return eq 'NEW') {
        $return = 'NEW';
    } elsif ($return eq 'OLD' || $return =~ /^PREV(?:IOUS)?$/ || $return eq 'PRIOR') {
        $return = 'OLD';
    } elsif ($return eq 'SELF' || $return =~ /^OBJ(?:ECT)?$/) {
        $return = 'SELF';
    } else {
        OIO::Attribute->die(
            'message'   => q/Can't create accessor method/,
            'Info'      => "Invalid setting for 'RETURN': $return",
            'Attribute' => $attr);
    }

    # Get type checking (if any)
    my ($type, $subtype, $is_ref) = ('NONE', '', 0);
    if ($$fld_type{$field_ref}) {
        $type = $$fld_type{$field_ref}{'type'};
        if (! ref($type)) {
            if ($type =~ /^(.*)\((.+)\)$/i) {
                $type = $1;
                $subtype = $2;
            }
            if ($type =~ /^(HASH|ARRAY|SCALAR)_ref$/) {
                $type = $1;
                $is_ref = 1;
            }
        }
    }
    if ($subtype && ($type ne 'list' && $type ne 'ARRAY')) {
        OIO::Attribute->die(
            'message'   => "Invalid type specification for package '$pkg'",
            'Info'      => "Type '$type' cannot have subtypes",
            'Attribute' => $attr);
    }

    # Metadata
    my %meta;
    if ($set) {
        $meta{$set}{'kind'} = ($get && ($get eq $set)) ? 'accessor' : 'set';
        if ($lvalue) {
            $meta{$set}{'lvalue'} = 1;
        }
        $meta{$set}{'return'} = lc($return);
        # Type
        if (ref($type)) {
            $meta{$set}{'type'} = $$fld_type{$field_ref}{'code'};
        } elsif ($type ne 'NONE') {
            $meta{$set}{'type'} = $type;
        }
        if ($subtype) {
            $meta{$set}{'type'} .= "($subtype)";
        }
    }
    if ($get && (!$set || ($get ne $set))) {
        $meta{$get}{'kind'} = 'get';
    }
    foreach my $meth ($get, $set) {
        next if (! $meth);
        # Permissions
        if (defined($private)) {
            $meta{$meth}{'hidden'} = 1;
        } elsif (defined($restricted)) {
            $meta{$meth}{'restricted'} = 1;
        }
    }
    add_meta($pkg, \%meta);

    my $weak = $GBL{'fld'}{'weak'}{$field_ref};

    # Code to be eval'ed into subroutines
    my $code = "package $pkg;\n";

    # Create an :lvalue accessor
    if ($lvalue) {
        $code .= create_lvalue_accessor($pkg, $set, $field_ref, $get,
                                        $type, $is_ref, $subtype,
                                        $name, $return, $private,
                                        $restricted, $weak, $pre);
    }

    # Create 'set' or combination accessor
    elsif ($set) {
        # Begin with subroutine declaration in the appropriate package
        $code .= "*${pkg}::$set = sub {\n";

        $code .= preamble_code($pkg, $set, $private, $restricted);

        my $fld_str = (ref($field_ref) eq 'HASH') ? "\$field->\{\${\$_[0]}}" : "\$field->\[\${\$_[0]}]";

        # Add GET portion for combination accessor
        if ($get && ($get eq $set)) {
            $code .= "    return ($fld_str) if (\@_ == 1);\n";
        }

        # If set only, then must have at least one arg
        else {
            $code .= <<"_CHECK_ARGS_";
    if (\@_ < 2) {
        OIO::Args->die(
            'message'  => q/Missing arg(s) to '$pkg->$set'/,
            'location' => [ caller() ]);
    }
_CHECK_ARGS_
        }

        # Add preprocessing code block
        if ($pre) {
            $code .= <<"_PRE_";
    {
        my \@errs;
        local \$SIG{'__WARN__'} = sub { push(\@errs, \@_); };
        eval {
            my \$self = shift;
            \@_ = (\$self, \$preproc->(\$self, \$field, \@_));
        };
        if (\$@ || \@errs) {
            my (\$err) = split(/ at /, \$@ || join(" | ", \@errs));
            OIO::Code->die(
                'message' => q/Problem with preprocessing routine for '$pkg->$set'/,
                'Error'   => \$err);
        }
    }
_PRE_
        }

        # Add data type checking
        my ($type_code, $arg_str) = type_code($pkg, $set, $weak,
                                              $type, $is_ref, $subtype);
        $code .= $type_code;

        # Add field locking code if sharing
        if (is_sharing($pkg)) {
            $code .= "    lock(\$field);\n"
        }

        # Grab 'OLD' value
        if ($return eq 'OLD') {
            $code .= "    my \$ret = $fld_str;\n";
        }

        # Add actual 'set' code
        $code .= (is_sharing($pkg))
              ? "    $fld_str = Object::InsideOut::Util::make_shared($arg_str);\n"
              : "    $fld_str = $arg_str;\n";
        if ($weak) {
            $code .= "    Scalar::Util::weaken($fld_str);\n";
        }

        # Add code for return value
        if ($return eq 'SELF') {
            $code .= "    \$_[0];\n";
        } elsif ($return eq 'OLD') {
            if ($use_want) {
                $code .= "    ((Want::wantref() eq 'OBJECT') && !Scalar::Util::blessed(\$ret)) ? \$_[0] : ";
            }
            $code .= "\$ret;\n";
        } elsif ($use_want) {
            $code .= "    ((Want::wantref() eq 'OBJECT') && !Scalar::Util::blessed($fld_str)) ? \$_[0] : $fld_str;\n";
        } elsif ($weak) {
            $code .= "    $fld_str;\n";
        }

        # Done
        $code .= "};\n";
    }
    undef($type) if (! ref($type));

    # Create 'get' accessor
    if ($get && (!$set || ($get ne $set))) {
        $code .= "*${pkg}::$get = sub {\n"

               . preamble_code($pkg, $get, $private, $restricted, 'readonly')

               . ((ref($field_ref) eq 'HASH')
                    ? "    \$field->{\${\$_[0]}};\n};\n"
                    : "    \$field->[\${\$_[0]}];\n};\n");
    }

    # Create delegation accessor
    if ($delegate) {
        $delegate =~ s/\s*-->\s*/-->/g;
        my @methods = split(/[,\s]+/, $delegate);
        @methods = grep { $_ } @methods;
        @methods = map  { get_class_methods($pkg, $_) } @methods;
        for my $method (@methods) {
            my ($from, $to) = split(/-->/, $method);
            if (! defined($to)) {
                $to = $from;
            }
            no strict 'refs';
            if (*{$pkg.'::'.$from}{CODE}) {
                OIO::Attribute->die(
                    'message'   => q/Can't create delegator method/,
                    'Info'      => "Method '$from' already exists in class '$pkg'",
                    'Attribute' => $attr);
            }
            $code .= "*${pkg}::$from = sub {\n"

                . preamble_code($pkg, $method, $private, $restricted)

                . "    my \$self = shift;\n"

                . ((ref($field_ref) eq 'HASH')
                        ? "    \$field->{\${\$self}}->$to(\@_);\n};\n"
                        : "    \$field->[\${\$self}]->$to(\@_);\n};\n");
        }
    }

    # Compile the subroutine(s) in the smallest possible lexical scope
    my @errs;
    local $SIG{'__WARN__'} = sub { push(@errs, @_); };
    {
        my $field      = $field_ref;
        my $type_check = $type;
        my $preproc    = $pre;
        eval $code;
    }
    if ($@ || @errs) {
        my ($err) = split(/ at /, $@ || join(" | ", @errs));
        OIO::Internal->die(
            'message'     => "Failure creating accessor for class '$pkg'",
            'Error'       => $err,
            'Declaration' => $attr,
            'Code'        => $code,
            'self'        => 1);
    }
}


# Generate code for start of accessor
sub preamble_code :Sub(Private)
{
    my ($pkg, $name, $private, $restricted, $readonly) = @_;
    my $code = '';

    # Argument checking code
    if (defined($readonly)) {
        $code = <<"_READONLY_";
    if (\@_ > 1) {
        OIO::Method->die('message' => "Can't call readonly accessor method '$pkg->$name' with an argument");
    }
_READONLY_
    }

    # Permission checking code
    if (defined($private)) {
        $code = <<"_PRIVATE_";
    my \$caller = caller();
    if (! grep { \$_ eq \$caller } ($private)) {
        OIO::Method->die('message' => "Can't call private method '$pkg->$name' from class '\$caller'");
    }
_PRIVATE_
    } elsif (defined($restricted)) {
        $code = <<"_RESTRICTED_";
    my \$caller = caller();
    if (! ((grep { \$_ eq \$caller } ($restricted)) ||
           \$caller->isa('$pkg')                   ||
           $pkg->isa(\$caller)))
    {
        OIO::Method->die('message'  => "Can't call restricted method '$pkg->$name' from class '\$caller'");
    }
_RESTRICTED_
    }

    return ($code);
}


# Generate type checking code
sub type_code :Sub(Private)
{
    my ($pkg, $name, $weak, $type, $is_ref, $subtype) = @_;
    my $code = '';
    my $arg_str = '$_[1]';

    # Type checking code
    if (ref($type)) {
        $code = <<"_CODE_";
    {
        my (\$ok, \@errs);
        local \$SIG{'__WARN__'} = sub { push(\@errs, \@_); };
        eval { \$ok = \$type_check->($arg_str) };
        if (\$@ || \@errs) {
            my (\$err) = split(/ at /, \$@ || join(" | ", \@errs));
            OIO::Code->die(
                'message' => q/Problem with type check routine for '$pkg->$name'/,
                'Error'   => \$err);
        }
        if (! \$ok) {
            OIO::Args->die(
                'message'  => "Argument to '$pkg->$name' failed type check: $arg_str",
                'location' => [ caller() ]);
        }
    }
_CODE_

    } elsif ($type eq 'NONE') {
        # For 'weak' fields, the data must be a ref
        if ($weak) {
            $code = <<"_WEAK_";
    if (! ref($arg_str)) {
        OIO::Args->die(
            'message'  => "Bad argument: $arg_str",
            'Usage'    => q/Argument to '$pkg->$name' must be a reference/,
            'location' => [ caller() ]);
    }
_WEAK_
        }

    } elsif ($type eq 'scalar') {
        # One scalar argument
        $code = <<"_SCALAR_";
    if (ref($arg_str)) {
        OIO::Args->die(
            'message'  => "Bad argument: $arg_str",
            'Usage'    => q/Argument to '$pkg->$name' must be a scalar/,
            'location' => [ caller() ]);
    }
_SCALAR_

    } elsif ($type eq 'numeric') {
        # One numeric argument
        $code = <<"_NUMERIC_";
    if (! Scalar::Util::looks_like_number($arg_str)) {
        OIO::Args->die(
            'message'  => "Bad argument: $arg_str",
            'Usage'    => q/Argument to '$pkg->$name' must be a number/,
            'location' => [ caller() ]);
    }
_NUMERIC_

    } elsif ($type eq 'list') {
        # List/array - 1+ args or array ref
        $code = <<'_ARRAY_';
    my $arg;
    if (@_ == 2 && ref($_[1]) eq 'ARRAY') {
        $arg = $_[1];
    } else {
        my @args = @_;
        shift(@args);
        $arg = \@args;
    }
_ARRAY_
        $arg_str = '$arg';

    } elsif ($type eq 'HASH' && !$is_ref) {
        # Hash - pairs of args or hash ref
        $code = <<"_HASH_";
    my \$arg;
    if (\@_ == 2 && ref(\$_[1]) eq 'HASH') {
        \$arg = \$_[1];
    } elsif (\@_ % 2 == 0) {
        OIO::Args->die(
            'message'  => q/Odd number of arguments: Can't create hash ref/,
            'Usage'    => q/'$pkg->$name' requires a hash ref or an even number of args (to make a hash ref)/,
            'location' => [ caller() ]);
    } else {
        my \@args = \@_;
        shift(\@args);
        my \%args = \@args;
        \$arg = \\\%args;
    }
_HASH_
        $arg_str = '$arg';

    } else {
        # One object or ref arg - exact spelling and case required
        $code = <<"_REF_";
    if (! Object::InsideOut::Util::is_it($arg_str, '$type')) {
        OIO::Args->die(
            'message'  => q/Bad argument: Wrong type/,
            'Usage'    => q/Argument to '$pkg->$name' must be of type '$type'/,
            'location' => [ caller() ]);
    }
_REF_
    }

    # Subtype checking code
    if ($subtype) {
        if ($subtype =~ /^scalar$/i) {
            $code .= <<"_SCALAR_SUBTYPE_";
    foreach my \$elem (\@{$arg_str}) {
        if (ref(\$elem)) {
            OIO::Args->die(
                'message'  => q/Bad argument: Wrong type/,
                'Usage'    => q/Values to '$pkg->$name' must be scalars/,
                'location' => [ caller() ]);
        }
    }
_SCALAR_SUBTYPE_
        } elsif ($subtype =~ /^num(?:ber|eric)?$/i) {
            $code .= <<"_NUM_SUBTYPE_";
    foreach my \$elem (\@{$arg_str}) {
        if (! Scalar::Util::looks_like_number(\$elem)) {
            OIO::Args->die(
                'message'  => q/Bad argument: Wrong type/,
                'Usage'    => q/Values to '$pkg->$name' must be numeric/,
                'location' => [ caller() ]);
        }
    }
_NUM_SUBTYPE_
        } else {
            $code .= <<"_SUBTYPE_";
    foreach my \$elem (\@{$arg_str}) {
        if (! Object::InsideOut::Util::is_it(\$elem, '$subtype')) {
            OIO::Args->die(
                'message'  => q/Bad argument: Wrong type/,
                'Usage'    => q/Values to '$pkg->$name' must be of type '$subtype'/,
                'location' => [ caller() ]);
        }
    }
_SUBTYPE_
        }
    }

    return ($code, $arg_str);
}


### Wrappers ###

# Returns a 'wrapper' closure back to initialize() that adds merged argument
# support for a method.
sub wrap_MERGE_ARGS :Sub(Private)
{
    my $code = shift;
    return sub {
        my $self = shift;

        # Gather arguments into a single hash ref
        my $args = {};
        while (my $arg = shift) {
            if (ref($arg) eq 'HASH') {
                # Add args from a hash ref
                @{$args}{keys(%{$arg})} = values(%{$arg});
            } elsif (ref($arg)) {
                OIO::Args->die(
                    'message'  => "Bad initializer: @{[ref($arg)]} ref not allowed",
                    'Usage'    => q/Args must be 'key=>val' pair(s) and\/or hash ref(s)/);
            } elsif (! @_) {
                OIO::Args->die(
                    'message'  => "Bad initializer: Missing value for key '$arg'",
                    'Usage'    => q/Args must be 'key=>val' pair(s) and\/or hash ref(s)/);
            } else {
                # Add 'key => value' pair
                $$args{$arg} = shift;
            }
        }

        @_ = ($self, $args);
        goto $code;
    };
}


# Returns a 'wrapper' closure back to initialize() that restricts a method
# to being only callable from within its class hierarchy
sub wrap_RESTRICTED :Sub(Private)
{
    my ($pkg, $method, $code, $exempt) = @_;
    return sub {
        # Caller must be in class hierarchy, or be specified as an exemption
        my $caller = caller();
        if (! ((grep { $_ eq $caller } @$exempt) ||
               $caller->isa($pkg) ||
               $pkg->isa($caller)))
        {
            OIO::Method->die('message' => "Can't call restricted method '$pkg->$method' from class '$caller'");
        }
        goto $code;
    };
}


# Returns a 'wrapper' closure back to initialize() that makes a method
# private (i.e., only callable from within its own class).
sub wrap_PRIVATE :Sub(Private)
{
    my ($pkg, $method, $code, $exempt) = @_;
    return sub {
        # Caller must be in the package, or be specified as an exemption
        my $caller = caller();
        if (! grep { $_ eq $caller } @$exempt) {
            OIO::Method->die('message' => "Can't call private method '$pkg->$method' from class '$caller'");
        }
        goto $code;
    };
}


# Returns a 'wrapper' closure back to initialize() that makes a subroutine
# uncallable - with the original code ref stored elsewhere, of course.
sub wrap_HIDDEN :Sub(Private)
{
    my ($pkg, $method) = @_;
    return sub {
        OIO::Method->die('message' => "Can't call hidden method '$pkg->$method'");
    }
}


### Delayed Loading ###

# Loads sub-modules
sub load :Sub(Private)
{
    my $mod = shift;
    my $file = "Object/InsideOut/$mod.pm";

    if (! exists($INC{$file})) {
        # Load the file
        my $rc = do($file);

        # Check for errors
        if ($@) {
            OIO::Internal->die(
                'message'     => "Failure compiling file '$file'",
                'Error'       => $@,
                'self'        => 1);
        } elsif (! defined($rc)) {
            OIO::Internal->die(
                'message'     => "Failure reading file '$file'",
                'Error'       => $!,
                'self'        => 1);
        } elsif (! $rc) {
            OIO::Internal->die(
                'message'     => "Failure processing file '$file'",
                'Error'       => $rc,
                'self'        => 1);
        }
    }
}

sub generate_CUMULATIVE :Sub(Private)
{
    load('Cumulative');
    goto &generate_CUMULATIVE;
}

sub create_CUMULATIVE :Sub(Private)
{
    load('Cumulative');
    goto &create_CUMULATIVE;
}

sub generate_CHAINED :Sub(Private)
{
    load('Chained');
    goto &generate_CHAINED;
}

sub create_CHAINED :Sub(Private)
{
    load('Chained');
    goto &create_CHAINED;
}

sub generate_OVERLOAD :Sub(Private)
{
    load('Overload');
    goto &generate_OVERLOAD;
}

sub install_UNIVERSAL :Sub(Private)
{
    load('Universal');
    @_ = (\%GBL);
    goto &install_UNIVERSAL;
}

sub install_ATTRIBUTES :Sub
{
    load('attributes');
    goto &install_ATTRIBUTES;
}

sub dump :Method(Object)
{
    load('Dump');
    @_ = (\%GBL, 'dump', @_);
    goto &dump;
}

sub pump :Method(Class)
{
    load('Dump');
    @_ = (\%GBL, 'pump', @_);
    goto &dump;
}

sub inherit :Method(Object)
{
    load('Foreign');
    @_ = (\%GBL, 'inherit', @_);
    goto &inherit;
}

sub heritage :Method(Object)
{
    load('Foreign');
    @_ = (\%GBL, 'heritage', @_);
    goto &inherit;
}

sub disinherit :Method(Object)
{
    load('Foreign');
    @_ = (\%GBL, 'disinherit', @_);
    goto &inherit;
}

sub create_heritage :Sub(Private)
{
    load('Foreign');
    @_ = (\%GBL, 'create_heritage', @_);
    goto &inherit;
}

sub create_field :Method(Class)
{
    load('Dynamic');
    @_ = (\%GBL, 'create_field', @_);
    goto &create_field;
}

sub add_class :Method(Class)
{
    load('Dynamic');
    @_ = (\%GBL, 'add_class', @_);
    goto &create_field;
}

sub AUTOLOAD :Sub
{
    load('Autoload');
    @_ = (\%GBL, @_);
    goto &Object::InsideOut::AUTOLOAD;
}

sub create_lvalue_accessor :Sub(Private)
{
    load('lvalue');
    goto &create_lvalue_accessor;
}


### Initialization and Termination ###

# Initialize the package after loading
initialize();

{
    # Initialize as part of the CHECK phase
    no warnings 'void';
    CHECK {
        initialize();
    }
}

# Initialize just before cloning a thread
sub CLONE_SKIP
{
    if ($_[0] eq 'Object::InsideOut') {
        initialize();
    }
    return 0;
}

# Workaround for Perl's "in cleanup" bug
END {
    $GBL{'term'} = 1;
}

}  # End of package's lexical scope

1;
# EOF