package Object::InsideOut; {

require 5.006;

use strict;
use warnings;

our $VERSION = '1.01.00';

my $DO_INIT = 1;   # Flag for running package initialization routine

### Exception Processing ###

# Exceptions generated by this module
use Exception::Class (
    'OIO' => {
        'description' => 'Generic Object::InsideOut exception',
        # First 3 fields must be:  'Package', 'File', 'Line'
        'fields' => ['Package', 'File', 'Line', 'Error'],
    },

    'OIO::Code' => {
        'isa' => 'OIO',
        'description' =>
            'Object::InsideOut exception that indicates a coding error',
        'fields' => ['Info'],
    },

    'OIO::Internal' => {
        'isa' => 'OIO::Code',
        'description' =>
            'Object::InsideOut exception that indicates a internal problem',
        'fields' => ['Code', 'Declaration'],
    },

    'OIO::Attribute' => {
        'isa' => 'OIO::Code',
        'description' =>
            'Object::InsideOut exception that indicates a coding error',
        'fields' => ['Attribute'],
    },

    'OIO::Method' => {
        'isa' => 'OIO',
        'description' =>
            'Object::InsideOut exception that indicates an method calling error',
    },

    'OIO::Args' => {
        'isa' => 'OIO::Method',
        'description' =>
            'Object::InsideOut exception that indicates an argument error',
        'fields' => ['Usage', 'Arg'],
    },
);


# A 'throw' method that adds location information to the exception object
sub OIO::die
{
    my $class = shift;
    my %args  = @_;

    # Get location information
    my ($pkg, $file, $line);

    if (exists($args{'location'})) {
        # Location specified in an array ref
        ($pkg, $file, $line) = @{delete($args{'location'})};

    } elsif (exists($args{'caller_level'})) {
        # Location specified as a caller() level
        ($pkg, $file, $line) = caller(1 + delete($args{'caller_level'}));

    } else {
        # Default location
        ($pkg, $file, $line) = caller(1);
    }

    $class->throw(%args,
                  'Package' => $pkg,
                  'File'    => $file,
                  'Line'    => $line);
}


# Provides a fully formated error message for the exception object
sub OIO::full_message
{
    my $self = shift;

    # Start with error class and message
    my $msg = ref($self) . ' error: ' . $self->message();
    chomp($msg);

    # Add fields, if any
    my @fields = $self->Fields();
    shift(@fields) for (1..3);   # Drop location fields
    for my $field (@fields) {
        if (exists($self->{$field})) {
            $msg .= "\n$field: " . $self->{$field};
            chomp($msg);
        }
    }

    # Add location
    if (defined($self->{'Package'})) {
        $msg .= "\nPackage: " . $self->{'Package'}
              . "\nFile: "    . $self->{'File'}
              . "\nLine: "    . $self->{'Line'};
    }

    return ($msg . "\n");
}


# Catch untrapped errors
# Usage:  local $SIG{__DIE__} = 'OIO::trap';
sub OIO::trap
{
    # Just rethrow if already an exception object
    if (Object::InsideOut::Util::is_it($_[0], 'Exception::Class::Base')) {
        $_[0]->rethrow();
    }

    # Turn on stack trace
    OIO->Trace(1);

    # Package the error into an object
    OIO->die(
        'message' => 'Trapped uncaught error',
        'Error'   => join('', @_));
}


### Additional Supporting Code ###

require Object::InsideOut::Util;

use Scalar::Util 1.10;

BEGIN {
    # Verify we have 'weaken'
    if (! Scalar::Util->can('weaken')) {
        OIO::Code->die(
            'message' => q/Cannot use 'pure perl' version of Scalar::Util - 'weaken' missing/,
            'Info'    => q/Upgrade your version of Scalar::Util/);
    }
}

### Class Tree Building (via 'import()') ###

# Cache of class trees
my (%TREE_TOP_DOWN, %TREE_BOTTOM_UP);

# Doesn't export anything - just builds class trees and stores sharing flags
sub import
{
    my $self  = shift;      # Ourself (i.e., 'Object::InsideOut')
    my $class = caller();   # The class that is using us

    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]);
    }

    # 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;
        }

        # Load the package, if needed
        if (! $class->isa($pkg)) {
            if (! @{$pkg.'::ISA'}) {
                eval "require $pkg";
                if ($@) {
                    OIO::Code->die(
                        'message' => "Failure loading package '$pkg'",
                        'Error'   => $@);
                }
            }

            # 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");
            }
            eval { import $pkg @{$imports}; };
            if ($@) {
                OIO::Code->die(
                    'message' => "Failure running 'import' on package '$pkg'",
                    'Error'   => $@);
            }
        }
    }

    # Create calling class's @ISA array
    push(@{$class.'::ISA'}, $self, @packages);

    # Create class tree
    my @tree;
    my %seen;   # Used to prevent duplicate entries in @tree
    for my $parent (@packages) {
        # Parent class must exist
        if (! exists($TREE_TOP_DOWN{$parent})) {
            OIO::Code->die(
                'message' => "Cannot declare '$parent' as a parent class for '$class'",
                'Error'   => "Class '$parent' is not an Object::InsideOut class");
        }

        for my $ancestor (@{$TREE_TOP_DOWN{$parent}}) {
            if (! exists($seen{$ancestor})) {
                push(@tree, $ancestor);
                $seen{$ancestor} = undef;
            }
        }
    }

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

    # Save the trees
    $TREE_TOP_DOWN{$class} = \@tree;
    @{$TREE_BOTTOM_UP{$class}} = reverse(@tree);
}


### Attribute Support ###

# Maintain references to all object field hashes by package for easy
# manipulation of field data during global object actions (e.g., cloning,
# destruction).  Object field hashes are marked with an attribute called
# 'Field'.
my %FIELDS;

# Field information for the dump() method
my %DUMP_FIELDS;

# Packages with :InitArgs that need to be processed for dump() field info
my @DUMP_INITARGS;

# Allow a single object ID specifier subroutine per class tree.  The
# subroutine ref provided will return the object ID to be used for the object
# that is created by this package.  The ID subroutine is marked with an
# attribute called 'ID', and is :HIDDEN during initialization by default.
my %ID_SUBS;

# Allow a single object initialization hash per class.  The data in these
# hashes is used to initialize newly create objects. The initialization hash
# is marked with an attribute called 'InitArgs'.
my %INIT_ARGS;

# Allow a single initialization subroutine per class that is called as part of
# initializing newly created objects.  The initialization subroutine is marked
# with an attributed called 'Init', and is :HIDDEN during initialization by
# default.
my %INITORS;

# Allow a single data replication subroutine per class that is called when
# objects are cloned.  The data replication subroutine is marked with an
# attributed called 'Replicate', and is :HIDDEN during initialization by
# default.
my %REPLICATORS;

# Allow a single data destruction subroutine per class that is called when
# objects are destroyed.  The data destruction subroutine is marked with an
# attributed called 'Destroy', and is :HIDDEN during initialization by
# default.
my %DESTROYERS;

# Allow a single 'autoload' subroutine per class that is called when an object
# method is not found.  The automethods subroutine is marked with an
# attributed called 'Automethod', and is :HIDDEN during initialization by
# default.
my %AUTOMETHODS;

# Methods that support 'cumulativity' from the top of the class tree
# downwards.  These cumulative methods are marked with an attributed called
# 'Cumulative'.
my %CUMULATIVE;

# Methods that support 'cumulativity' from the bottom of the class tree
# upwards.  These cumulative methods are marked with an attributed
# 'Cumulative(bottom up)'.
my %ANTICUMULATIVE;

# Methods that support 'chaining' from the top of the class tree downwards.
# These chained methods are marked with an attributed called 'Chained'.
my %CHAINED;

# Methods that support 'chaining' from the bottom of the class tree upwards.
# These chained methods are marked with an attributed 'Chained(bottom up)'.
my %ANTICHAINED;

my %DUMPERS;
my %PUMPERS;

# Restricted methods are only callable from within the class hierarchy, and
# are marked with an attributed called 'Restricted'.
my %RESTRICTED;

# Restricted methods are only callable from within the class itself, and are
# marked with an attributed called 'Private'.
my %PRIVATE;

# Methods that are made uncallable after initialization.  They are marked with
# an attributed called 'HIDDEN'.
my %HIDDEN;

# Methods that are support overloading capabilities for objects.
my %OVERLOAD;

# These are the attributes for designating 'overload' methods.
my %OVERLOAD_TYPES = (
    'STRINGIFY' => q/""/,
    'NUMERIFY'  => q/0+/,
    'BOOLIFY'   => q/bool/,
    'ARRAYIFY'  => q/@{}/,
    'HASHIFY'   => q/%{}/,
    'GLOBIFY'   => q/*{}/,
    'CODIFY'    => q/&{}/,
);


# This subroutine handles attributes on hashes as part of this package.
# See 'perldoc attributes' for details.
sub MODIFY_HASH_ATTRIBUTES
{
    my ($pkg, $hash, @attrs) = @_;

    my @unused_attrs;   # List of any unhandled attributes

    # Process attributes
    for my $attr (@attrs) {
        # Declaration for object field hash
        if ($attr =~ /^Field/i) {
            # Save save hash ref and accessor declarations
            # Accessors will be build during initialization
            my ($decl) = $attr =~ /^Fields?\s*(?:[(]\s*(.*)\s*[)])/i;
            push(@{$FIELDS{$pkg}}, [ $hash, $decl ]);
            $DO_INIT = 1;   # Flag that initialization is required
        }

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

        # Handle ':shared' attribute associated with threads::shared
        elsif ($attr eq 'shared') {
            if ($threads::shared::threads_shared) {
                threads::shared::share($hash);
            }
        }

        # Unhandled
        else {
            push(@unused_attrs, $attr);
        }
    }

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


# This subroutine handles attributes on arrays as part of this package.
# See 'perldoc attributes' for details.
sub MODIFY_ARRAY_ATTRIBUTES
{
    my ($pkg, $array, @attrs) = @_;

    my @unused_attrs;   # List of any unhandled attributes

    # Process attributes
    for my $attr (@attrs) {
        # Declaration for object field array
        if ($attr =~ /^Field/i) {
            # Save save array ref and accessor declarations
            # Accessors will be build during initialization
            my ($decl) = $attr =~ /^Fields?\s*(?:[(]\s*(.*)\s*[)])/i;
            push(@{$FIELDS{$pkg}}, [ $array, $decl ]);
            $DO_INIT = 1;   # Flag that initialization is required
        }

        # Handle ':shared' attribute associated with threads::shared
        elsif ($attr eq 'shared') {
            if ($threads::shared::threads_shared) {
                threads::shared::share($array);
            }
        }

        # Unhandled
        else {
            push(@unused_attrs, $attr);
        }
    }

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


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

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

    my @unused_attrs;   # List of any unhandled attributes

    # Save the code refs in the appropriate hashes
    ATTR:
    while (my $attribute = shift(@attrs)) {
        my ($attr, $arg) = $attribute =~ /(\w+)(?:[(]\s*(.*)\s*[)])?/;
        $attr = uc($attr);
        # Attribute may be followed by 'PUBLIC', 'PRIVATE' or 'RESTRICED'
        # Default to 'HIDDEN' if none.
        $arg = ($arg) ? uc($arg) : 'HIDDEN';

        if ($attr eq 'ID') {
            $ID_SUBS{$pkg} = [ $code, @{$info->[1]} ];
            # Process attribute 'arg' as an attribute
            push(@attrs, $arg) if $] > 5.006;
            $DO_INIT = 1;   # Flag that initialization is required

        } elsif ($attr eq 'INIT') {
            $INITORS{$pkg} = $code;
            # Process attribute 'arg' as an attribute
            push(@attrs, $arg) if $] > 5.006;

        } elsif ($attr =~ /^REPL(?:ICATE)?$/) {
            $REPLICATORS{$pkg} = $code;
            # Process attribute 'arg' as an attribute
            push(@attrs, $arg) if $] > 5.006;

        } elsif ($attr =~ /^DEST(?:ROY)?$/) {
            $DESTROYERS{$pkg} = $code;
            # Process attribute 'arg' as an attribute
            push(@attrs, $arg) if $] > 5.006;

        } elsif ($attr =~ /^AUTO(?:METHOD)?$/) {
            $AUTOMETHODS{$pkg} = $code;
            # Process attribute 'arg' as an attribute
            push(@attrs, $arg) if $] > 5.006;
            $DO_INIT = 1;   # Flag that initialization is required

        } elsif ($attr =~ /^CUM(?:ULATIVE)?$/) {
            if ($arg =~ /BOTTOM\s+UP/) {
                push(@{$ANTICUMULATIVE{$pkg}}, $info);
            } else {
                push(@{$CUMULATIVE{$pkg}}, $info);
            }
            $DO_INIT = 1;   # Flag that initialization is required

        } elsif ($attr =~ /^CHAIN(?:ED)?$/) {
            if ($arg =~ /BOTTOM\s+UP/) {
                push(@{$ANTICHAINED{$pkg}}, $info);
            } else {
                push(@{$CHAINED{$pkg}}, $info);
            }
            $DO_INIT = 1;   # Flag that initialization is required

        } elsif ($attr =~ /^DUMP(?:ER)?$/) {
            $DUMPERS{$pkg} = $code;
            # Process attribute 'arg' as an attribute
            push(@attrs, $arg) if $] > 5.006;

        } elsif ($attr =~ /^PUMP(?:ER)?$/) {
            $PUMPERS{$pkg} = $code;
            # Process attribute 'arg' as an attribute
            push(@attrs, $arg) if $] > 5.006;

        } elsif ($attr =~ /^RESTRICT(?:ED)?$/) {
            push(@{$RESTRICTED{$pkg}}, $info);
            $DO_INIT = 1;   # Flag that initialization is required

        } elsif ($attr =~ /^PRIV(?:ATE)?$/) {
            push(@{$PRIVATE{$pkg}}, $info);
            $DO_INIT = 1;   # Flag that initialization is required

        } elsif ($attr eq 'HIDDEN') {
            push(@{$HIDDEN{$pkg}}, $info);
            $DO_INIT = 1;   # Flag that initialization is required

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

        } elsif ($attr =~ /IFY$/) {
            # Overload (-ify) attributes
            for my $ify_attr (keys(%OVERLOAD_TYPES)) {
                if ($attr eq $ify_attr) {
                    push(@{$OVERLOAD{$pkg}}, [$ify_attr, @{$info} ]);
                    next ATTR;
                }
            }
            $DO_INIT = 1;   # Flag that initialization is required

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

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


### Array Field Object Support ###

# Object ID counters - one for each class tree
my %ID_COUNTERS;
# Reclaimed object IDs
my %RECLAIMED_IDS;

if ($threads::shared::threads_shared) {
    threads::shared::share(%ID_COUNTERS);
    threads::shared::share(%RECLAIMED_IDS);
}

# Supplies an ID for an object being created in a class tree
# and reclaims IDs from destroyed objects
sub _ID
{
    my $class = shift;                # The object's class
    my $tree = $ID_SUBS{$class}[1];   # The object's class tree

    # Save deleted IDs for later reuse
    if (@_) {
        local $SIG{__WARN__} = sub { };   # Suppress spurious msg
        if (keys(%RECLAIMED_IDS)) {       # Perl bug workaround
            if (! exists($RECLAIMED_IDS{$tree})) {
                $RECLAIMED_IDS{$tree} = ($threads::shared::threads_shared)
                                            ? &threads::shared::share([])
                                            : [];
            }
            push(@{$RECLAIMED_IDS{$tree}}, $_[0]);
        }
        return;
    }

    # Use a reclaimed ID if available
    if (exists($RECLAIMED_IDS{$tree}) && @{$RECLAIMED_IDS{$tree}}) {
        return (shift(@{$RECLAIMED_IDS{$tree}}));
    }

    # Return the next ID
    return (++$ID_COUNTERS{$tree});
}


### Initialization Handling ###

# Forward declaration of thread object sharing flag hash
# (Used in initialize() below)
my %IS_SHARING;


# Finds a subroutine's name in a package from its code ref
sub sub_name : PRIVATE
{
    my ($pkg, $ref, $attr, $location) = @_;
    no strict 'refs';
    for my $name (keys(%{$pkg.'::'})) {
        my $candidate = *{$pkg.'::'.$name}{'CODE'};
        if ($candidate && $candidate == $ref) {
            return $name;
        }
    }

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


# The old INITIALIZE subroutine is deprecated
sub INITIALIZE { return; }


# Perform much of the 'magic' for this module
sub initialize : Private
{
    # Bring in support class if needed
    if (%CUMULATIVE || %ANTICUMULATIVE || %CHAINED || %ANTICHAINED) {
        require Object::InsideOut::Results;
    }

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

    PROPAGATE_ID_SUBS:
    {
        # Propagate ID subs through the class hierarchies
        for my $class (keys(%TREE_TOP_DOWN)) {
            # Find and ID sub for this class somewhere in its hierarchy
            my $id_sub_pkg;
            for my $pkg (@{$TREE_TOP_DOWN{$class}}) {
                if ($ID_SUBS{$pkg}) {
                    if ($id_sub_pkg) {
                        # Verify that all the ID subs in heirarchy are the same
                        if (($ID_SUBS{$pkg}[0] != $ID_SUBS{$id_sub_pkg}[0]) ||
                            ($ID_SUBS{$pkg}[1] ne $ID_SUBS{$id_sub_pkg}[1]))
                        {
                            my ($p,    $file,  $line)  = @{$ID_SUBS{$pkg}}[1..3];
                            my ($pkg2, $file2, $line2) = @{$ID_SUBS{$id_sub_pkg}[1..3]};
                            OIO::Attribute->die(
                                'caller_level' => 2,
                                'message'      => "Multiple :ID subs defined within hierarchy for '$class'",
                                'Info'         => ":ID subs in class '$pkg' (file '$file', line $line), and class '$pkg2' (file '$file2' line $line2)");
                        }
                    } else {
                        $id_sub_pkg = $pkg;
                    }
                }
            }

            # If ID sub found, propagate it through the class hierarchy
            if ($id_sub_pkg) {
                for my $pkg (@{$TREE_TOP_DOWN{$class}}) {
                    $ID_SUBS{$pkg} = $ID_SUBS{$id_sub_pkg};
                }
            }
        }

        # Check for any classes without ID subs
        for my $class (keys(%TREE_TOP_DOWN)) {
            if (! exists($ID_SUBS{$class})) {
                # Default to internal ID sub and propagate it
                $ID_SUBS{$class} = [ \&_ID, $class, '-', '-' ];
                redo PROPAGATE_ID_SUBS;
            }
        }
    }


    # If needed, process any thread object sharing flags
    if (%IS_SHARING && $threads::shared::threads_shared) {
        for my $flag_class (keys(%IS_SHARING)) {
            # Find the class in any class tree
            for my $tree (values(%TREE_TOP_DOWN)) {
                if (grep /^$flag_class$/, @$tree) {
                    # Check each class in the tree
                    for my $class (@$tree) {
                        if (exists($IS_SHARING{$class})) {
                            # Check for sharing conflicts
                            if ($IS_SHARING{$class}[0] != $IS_SHARING{$flag_class}[0]) {
                                my ($pkg1, @loc, $pkg2, $file, $line);
                                if ($IS_SHARING{$flag_class}[0]) {
                                    $pkg1 = $flag_class;
                                    @loc  = ($flag_class, (@{$IS_SHARING{$flag_class}})[1..2]);
                                    $pkg2 = $class;
                                    ($file, $line) = (@{$IS_SHARING{$class}})[1..2];
                                } else {
                                    $pkg1 = $class;
                                    @loc  = ($class, (@{$IS_SHARING{$class}})[1..2]);
                                    $pkg2 = $flag_class;
                                    ($file, $line) = (@{$IS_SHARING{$flag_class}})[1..2];
                                }
                                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 '$pkg2' was declared as non-sharing in '$file' line $line");
                            }
                        } else {
                            # Add the sharing flag to this class
                            $IS_SHARING{$class} = $IS_SHARING{$flag_class};
                        }
                    }
                }
            }
        }
    }


    # Process :FIELD declarations for shared hashes/arrays and accessors
    for my $pkg (keys(%FIELDS)) {
        my @fields;
        for my $item (@{$FIELDS{$pkg}}) {
            if (ref($item) eq 'ARRAY') {
                my ($fld, $decl) = @{$item};

                # Share the field, if applicable
                if (is_sharing($pkg)) {
                    threads::shared::share($fld)
                }

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

                # Save hash/array refs
                push(@fields, $fld);

            } else {
                # Already processed
                push(@fields, $item);
            }
        }

        # :FIELD declarations have been removed
        $FIELDS{$pkg} = \@fields;
    }


    # Only install AUTOLOAD if we have Automethods
    if (%AUTOMETHODS) {
        if (! Object::InsideOut->can('AUTOLOAD')) {
            # Create AUTOLOAD under Object::InsideOut
            *Object::InsideOut::AUTOLOAD = create_AUTOLOAD(\%AUTOMETHODS,
                                                           \%TREE_BOTTOM_UP);

            # Install our version of UNIVERSAL::can that understands :Automethod
            *UNIVERSAL::can = create_UNIVERSAL_can(\&UNIVERSAL::can,
                                                   \%AUTOMETHODS,
                                                   \%TREE_BOTTOM_UP);
        }
    }


    # Implement cumulative methods
    if (%CUMULATIVE || %ANTICUMULATIVE) {
        # Get names for :CUMULATIVE methods
        my (%cum, %cum_loc);
        for my $package (keys(%CUMULATIVE)) {
            for my $info (@{$CUMULATIVE{$package}}) {
                my ($code, $location) = @{$info};
                my $name = sub_name($package, $code, ':CUMULATIVE', $location);
                $cum{$name}{$package} = $code;
                $cum_loc{$name}{$package} = $location;
            }
        }

        # Get names for :CUMULATIVE(BOTTOM UP) methods
        my %anticum;
        for my $package (keys(%ANTICUMULATIVE)) {
            for my $info (@{$ANTICUMULATIVE{$package}}) {
                my ($code, $location) = @{$info};
                my $name = sub_name($package, $code, ':CUMULATIVE(BOTTOM UP)', $location);

                # Check for conflicting definitions of $name
                if ($cum{$name}) {
                    for my $other_package (keys(%{$cum{$name}})) {
                        if ($other_package->isa($package) ||
                            $package->isa($other_package))
                        {
                            my ($pkg,  $file,  $line)  = @{$cum_loc{$name}{$other_package}};
                            my ($pkg2, $file2, $line2) = @{$location};
                            OIO::Attribute->die(
                                'location' => $location,
                                'message'  => "Conflicting definitions for cumulative method '$name'",
                                'Info'     => "Declared as :CUMULATIVE in class '$pkg' (file '$file', line $line), but declared as :CUMULATIVE(BOTTOM UP) in class '$pkg2' (file '$file2' line $line2)");
                        }
                    }
                }

                $anticum{$name}{$package} = $code;
            }
        }
        undef(%CUMULATIVE);      # No longer needed
        undef(%ANTICUMULATIVE);
        undef(%cum_loc);

        # Implement :CUMULATIVE methods
        for my $name (keys(%cum)) {
            for my $package (keys(%{$cum{$name}})) {
                *{$package.'::'.$name} = create_CUMULATIVE(\%TREE_TOP_DOWN,
                                                           $cum{$name});
            }
        }

        # Implement :CUMULATIVE(BOTTOM UP) methods
        for my $name (keys(%anticum)) {
            for my $package (keys(%{$anticum{$name}})) {
                *{$package.'::'.$name} = create_CUMULATIVE(\%TREE_BOTTOM_UP,
                                                           $anticum{$name});
            }
        }
    }


    # Implement chained methods
    if (%CHAINED || %ANTICHAINED) {
        # Get names for :CHAINED methods
        my (%chain, %chain_loc);
        for my $package (keys(%CHAINED)) {
            for my $info (@{$CHAINED{$package}}) {
                my ($code, $location) = @{$info};
                my $name = sub_name($package, $code, ':CHAINED', $location);
                $chain{$name}{$package} = $code;
                $chain_loc{$name}{$package} = $location;
            }
        }

        # Get names for :CHAINED(BOTTOM UP) methods
        my %antichain;
        for my $package (keys(%ANTICHAINED)) {
            for my $info (@{$ANTICHAINED{$package}}) {
                my ($code, $location) = @{$info};
                my $name = sub_name($package, $code, ':CHAINED(BOTTOM UP)', $location);

                # Check for conflicting definitions of $name
                if ($chain{$name}) {
                    for my $other_package (keys(%{$chain{$name}})) {
                        if ($other_package->isa($package) ||
                            $package->isa($other_package))
                        {
                            my ($pkg,  $file,  $line)  = @{$chain_loc{$name}{$other_package}};
                            my ($pkg2, $file2, $line2) = @{$location};
                            OIO::Attribute->die(
                                'location' => $location,
                                'message'  => "Conflicting definitions for chained method '$name'",
                                'Info'     => "Declared as :CHAINED in class '$pkg' (file '$file', line $line), but declared as :CHAINED(BOTTOM UP) in class '$pkg2' (file '$file2' line $line2)");
                        }
                    }
                }

                $antichain{$name}{$package} = $code;
            }
        }
        undef(%CHAINED);      # No longer needed
        undef(%ANTICHAINED);
        undef(%chain_loc);

        # Implement :CHAINED methods
        for my $name (keys(%chain)) {
            for my $package (keys(%{$chain{$name}})) {
                *{$package.'::'.$name} = create_CHAINED(\%TREE_TOP_DOWN,
                                                        $chain{$name});
            }
        }

        # Implement :CHAINED(BOTTOM UP) methods
        for my $name (keys(%antichain)) {
            for my $package (keys(%{$antichain{$name}})) {
                *{$package.'::'.$name} = create_CHAINED(\%TREE_BOTTOM_UP,
                                                        $antichain{$name});
            }
        }
    }


    # Implement overload (-ify) operators
    for my $package (keys(%OVERLOAD)) {
        for my $operation (@{$OVERLOAD{$package}}) {
            my ($attr, $code, $location) = @$operation;
            my $name = sub_name($package, $code, ":$attr", $location);
            {
                my @errs;
                local $SIG{__WARN__} = sub { push(@errs, @_); };

                my $code = sprintf(<<'_CODE_', $package, $OVERLOAD_TYPES{$attr}, $name);
package %s;
    use overload (
    q/%s/ => sub { $_[0]->%s() },
    'fallback' => 1
);
_CODE_
                eval $code;

                if ($@ || @errs) {
                    my ($err) = split(/ at /, $@ || join(" | ", @errs));
                    my ($pkg, $file, $line) = @{$location};
                    OIO::Internal->die(
                        'location' => [ __PACKAGE__, __FILE__, __LINE__ ],
                        'message'  => "Failure overloading :$attr for class '$pkg' (file '$file' line $line)",
                        'Error'    => $err,
                        'Code'     => $code);
                }
            }
        }
    }
    undef(%OVERLOAD);   # No longer needed

    for my $package (keys(%TREE_TOP_DOWN)) {
        # Bless an object into every class
        # This works around an obscure 'overload' bug reported against
        # Class::Std (http://rt.cpan.org/NoAuth/Bug.html?id=14048)
        bless(\do{ my $scalar; }, $package);

        # Verify that scalar dereferencing is not overloaded in any class
        if (exists(${$package.'::'}{'(${}'})) {
            (my $file = $package . '.pm') =~ s/::/\//g;
            OIO::Code->die(
                'location' => [ $package, $INC{$file} || '', '' ],
                'message'  => q/Overloading scalar dereferencing '${}' is not allowed/,
                'Info'     => q/The scalar of an object is its object ID, and can't be redefined/);
        }
    }


    # Implement restricted methods - only callable within hierarchy
    for my $package (keys(%RESTRICTED)) {
        for my $info (@{$RESTRICTED{$package}}) {
            my ($code, $location) = @{$info};
            my $name = sub_name($package, $code, ':RESTRICTED', $location);
            *{$package.'::'.$name} = create_RESTRICTED($package, $name, $code);
        }
    }
    undef(%RESTRICTED);   # No longer needed


    # Implement private methods - only callable from class itself
    for my $package (keys(%PRIVATE)) {
        for my $info (@{$PRIVATE{$package}}) {
            my ($code, $location) = @{$info};
            my $name = sub_name($package, $code, ':PRIVATE', $location);
            *{$package.'::'.$name} = create_PRIVATE($package, $name, $code);
        }
    }
    undef(%PRIVATE);   # No longer needed


    # Implement hidden methods - no longer callable by name
    for my $package (keys(%HIDDEN)) {
        for my $info (@{$HIDDEN{$package}}) {
            my ($code, $location) = @{$info};
            my $name = sub_name($package, $code, ':HIDDEN', $location);
            create_HIDDEN($package, $name);
        }
    }
    undef(%HIDDEN);   # No longer needed


    # Export certain methods to all classes
    my @EXPORT = qw(new clone DESTROY dump);
    if (%AUTOMETHODS) {
        push(@EXPORT, 'AUTOLOAD');
    }
    for my $pkg (keys(%TREE_TOP_DOWN)) {
        for my $sym (@EXPORT) {
            my $full_sym = $pkg.'::'.$sym;
            # Only export if method doesn't already exist
            if (! *{$full_sym}{CODE}) {
                *{$full_sym} = \&{$sym};
            }
        }
    }


    $DO_INIT = 0;   # Clear initialization flag
}


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


### Thread-Shared Object Support ###

# Contains flags as to whether or not a class is sharing objects between
# threads
#my %IS_SHARING;   # Declared above

sub set_sharing : PRIVATE
{
    my ($class, $sharing, $file, $line) = @_;
    $sharing = ($sharing) ? 1 : 0;

    if (exists($IS_SHARING{$class})) {
        if ($IS_SHARING{$class} != $sharing) {
            my (@loc, $nfile, $nline);
            if ($sharing) {
                @loc  = ($class, $file, $line);
                ($nfile, $nline) = (@{$IS_SHARING{$class}})[1..2];
            } else {
                @loc  = ($class, (@{$IS_SHARING{$class}})[1..2]);
                ($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 non-sharing in '$file' line $line");
        }
    } else {
        $IS_SHARING{$class} = [ $sharing, $file, $line ];
    }
}


# Internal subroutine that determines if a class's objects are shared between
# threads
sub is_sharing : PRIVATE
{
    my $class = $_[0];

    # If not 'use threads::shared;', return false
    if (! $threads::shared::threads_shared) {
        return;
    }

    return ($IS_SHARING{$class}[0]);
}


### Thread Cloning Support ###

# Thread cloning registry - maintains weak references to non-thread-shared
# objects for thread cloning
my %OBJECTS;

# Thread tracking registry - maintains thread lists for thread-shared objects
# to control object destruction
my %SHARED;
if ($threads::shared::threads_shared) {
    threads::shared::share(%SHARED);
}

# Thread ID is used to keep CLONE from executing more than once
my $THREAD_ID = 0;


# Called after thread is cloned
sub CLONE
{
    # Don't execute when called for subclasses
    if ($_[0] ne __PACKAGE__) {
        return;
    }

    # Don't execute twice for same thread
    if ($THREAD_ID == threads->tid()) {
        return;
    }

    # Set thread ID for the above
    $THREAD_ID = threads->tid();

    # Process thread-shared objects
    if (keys(%SHARED)) {    # Need keys() due to bug in older Perls
        lock(%SHARED);

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

    # Process non-thread-shared objects
    for my $class (keys(%OBJECTS)) {
        # Get class tree
        my @tree = @{$TREE_TOP_DOWN{$class}};

        # Get the ID sub for this class, if any
        my $id_sub = $ID_SUBS{$class}[0];

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

            } else {
                # Get cloned object associated with old ID
                $obj = delete($OBJECTS{$class}{$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 hashes/arrays with the new object ID
                for my $pkg (@tree) {
                    for my $fld (@{$FIELDS{$pkg}}) {
                        $fld->{$$obj} = delete($fld->{$old_id});
                    }
                }

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

            # Dispatch any special replication handling
            if (%REPLICATORS) {
                my $pseudo_object = \do{ my $scalar = $old_id; };
                for my $pkg (@tree) {
                    if (my $replicate = $REPLICATORS{$pkg}) {
                        local $SIG{__DIE__} = 'OIO::trap';
                        $replicate->($pseudo_object, $obj);
                    }
                }
            }
        }
    }
}


### Object Methods ###

# Object Constructor
sub new
{
    my $thing = shift;
    my $class = ref($thing) || $thing;

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

    # Perform package initialization, if required
    if ($DO_INIT) {
        initialize();
    }

    # Gather arguments into a single hash ref
    my $all_args = {};
    while (my $arg = shift) {
        if (ref($arg) eq 'HASH') {
            # Add args from a hash ref
            @{$all_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
            $all_args->{$arg} = shift;
        }
    }

    # Get thread-sharing flag
    my $am_sharing = is_sharing($class);

    # Create a new 'bare' object
    my $self = Object::InsideOut::Util::create_object($class,
                                                      $ID_SUBS{$class}[0]);
    if ($am_sharing) {
        threads::shared::share($self);
    }

    # Initialize object
    for my $pkg (@{$TREE_TOP_DOWN{$class}}) {
        my $spec = $INIT_ARGS{$pkg};
        my $init = $INITORS{$pkg};

        # Nothing to initialize for this class
        next if (!$spec && !$init);

        # If have InitArgs, then process args with it.  Otherwise, all the
        # args will be sent to the Init subroutine.
        my $args = ($spec) ? Object::InsideOut::Util::process_args($pkg,
                                                                   $self,
                                                                   $spec,
                                                                   $all_args)
                           : $all_args;

        if ($init) {
            # Send remaining args, if any, to Init subroutine
            local $SIG{__DIE__} = 'OIO::trap';
            $init->($self, $args);

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

    # Thread support
    if ($am_sharing) {
        # Add thread tracking list for this thread-shared object
        lock(%SHARED);
        if (! exists($SHARED{$class})) {
            $SHARED{$class} = &threads::shared::share({});
        }
        $SHARED{$class}{$$self} = &threads::shared::share([]);
        push(@{$SHARED{$class}{$$self}}, $THREAD_ID);

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

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


# Creates a copy of an object
sub clone
{
    my $parent = $_[0];
    my $class  = ref($parent);

    # Must call ->clone() as an object method
    if (! $class) {
        OIO::Method->die('message' => q/Can't call ->clone() as a class method/);
    }

    # Get thread-sharing flag
    my $am_sharing = is_sharing($class);

    # Create a new 'bare' object
    my $clone = Object::InsideOut::Util::create_object($class,
                                                       $ID_SUBS{$class}[0]);
    if ($am_sharing) {
        threads::shared::share($clone);
    }

    # Clone the object
    for my $pkg (@{$TREE_TOP_DOWN{$class}}) {
        # Clone field data from the parent
        for my $fld (@{$FIELDS{$pkg}}) {
            lock($fld) if ($am_sharing);
            if (ref($fld) eq 'HASH') {
                $fld->{$$clone} = $fld->{$$parent};
            } else {
                $fld->[$$clone] = $fld->[$$parent];
            }
        }

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

    # Thread support
    if ($am_sharing) {
        # Add thread tracking list for this thread-shared object
        lock(%SHARED);
        if (! exists($SHARED{$class})) {
            $SHARED{$class} = &threads::shared::share({});
        }
        $SHARED{$class}{$$clone} = &threads::shared::share([]);
        push(@{$SHARED{$class}{$$clone}}, $THREAD_ID);

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

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


# Object Destructor
sub DESTROY
{
    my $self  = $_[0];
    my $class = ref($self);

    if ($$self) {
        if (is_sharing($class)) {
            # Thread-shared object

            local $SIG{__WARN__} = sub { };     # Suppress spurious msg
            if (keys(%SHARED)) {                # Perl bug workaround

                # Remove thread ID for this object's thread tracking list
                lock(%SHARED);
                my $tid = pop(@{$SHARED{$class}{$$self}});
                while ($tid != $THREAD_ID) {
                    unshift(@{$SHARED{$class}{$$self}}, $tid);
                    $tid = pop(@{$SHARED{$class}{$$self}});
                }

                # If object is still active in other threads, then just return
                if (@{$SHARED{$class}{$$self}}) {
                    return;
                }

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

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

        # If sharing, then must lock object field hashes/arrays when updating
        my $lock_field = is_sharing($class);

        # Destroy object
        for my $pkg (@{$TREE_BOTTOM_UP{$class}}) {
            # Dispatch any special destruction handling
            if (my $destroy = $DESTROYERS{$pkg}) {
                local $SIG{__DIE__} = 'OIO::trap';
                $destroy->($self);
            }

            # Delete object field data
            for my $fld (@{$FIELDS{$pkg}}) {
                lock($fld) if ($lock_field);
                if (ref($fld) eq 'HASH') {
                    delete($fld->{$$self});
                } else {
                    delete($fld->[$$self]);
                }
            }
        }

        # Reclaim the object ID if applicable
        if ($ID_SUBS{$class}[0] == \&_ID) {
            _ID($class, $$self);
        }

        # Unlock the object
        Internals::SvREADONLY($$self, 0) if ($] >= 5.008003);
        # Erase the object ID - just in case
        $$self = undef;
    }
}


# The old _DUMP method is deprecated
sub _DUMP
{
    my $self = shift;
    return ($self->dump(@_));
}


# Object dumper
sub dump
{
    my $self = shift;

    # Extract field info from any :InitArgs hashes
    while (my $pkg = shift(@DUMP_INITARGS)) {
        INIT_ARGS:
        while (my ($name, $val) = each(%{$INIT_ARGS{$pkg}})) {
            if (ref($val) eq 'HASH') {
                if (my $field = Object::InsideOut::Util::hash_re($val, qr/^FIELD$/i)) {
                    # Override get/set names, but not 'Name'
                    while (my ($name2, $fld_spec) = each(%{$DUMP_FIELDS{$pkg}})) {
                        if ($field == $fld_spec->[0]) {
                            if ($fld_spec->[1] eq 'Name') {
                                next INIT_ARGS;
                            }
                            delete($DUMP_FIELDS{$pkg}{$name2});
                            last;
                        }
                    }
                    $DUMP_FIELDS{$pkg}{$name} = [ $field, 'InitArgs' ];
                }
            }
        }
    }

    # Class of the object
    my %dump;
    $dump{'CLASS'} = ref($self);

    # Gather data from the object's class tree
    for my $pkg (@{$TREE_TOP_DOWN{ref($self)}}) {
        # Try to use a class-supplied dumper
        if (my $dumper = $DUMPERS{$pkg}) {
            local $SIG{__DIE__} = 'OIO::trap';
            $dump{$pkg} = $dumper->($self);

        } else {
            # Dump the data ourselves from all known class fields
            my @fields = @{$FIELDS{$pkg}};

            # Fields for which we have names
            while (my ($name, $fld_spec) = each(%{$DUMP_FIELDS{$pkg}})) {
                my $field = $fld_spec->[0];
                if (ref($field) eq 'HASH') {
                    if (exists($field->{$$self})) {
                        $dump{$pkg}{$name} = $field->{$$self};
                    }
                } else {
                    if (exists($field->[$$self])) {
                        $dump{$pkg}{$name} = $field->[$$self];
                    }
                }
                @fields = grep { $_ != $field } @fields;
            }

            # Fields for which names are not known
            for my $field (@fields) {
                if (ref($field) eq 'HASH') {
                    if (exists($field->{$$self})) {
                        $dump{$pkg}{$field} = $field->{$$self};
                    }
                } else {
                    if (exists($field->[$$self])) {
                        $dump{$pkg}{$field} = $field->[$$self];
                    }
                }
            }
        }
    }

    # Create a string version of dumped data if arg is true
    if ($_[0]) {
        require Data::Dumper;
        my $dump = Data::Dumper::Dumper(\%dump);
        chomp($dump);
        $dump =~ s/^.{8}//gm;   # Remove initial 8 chars from each line
        $dump =~ s/;$//s;       # Remove trailing semi-colon
        return $dump;
    }

    # Send back a hash ref to the dumped data
    return (\%dump);
}


# Object loader
sub Object::InsideOut::pump
{
    my $input = $_[0];
    my $dump;

    # Must have an arg
    if (! $input) {
        OIO::Args->die('message' => 'Missing argument to pump()');
    }

    if (ref($input)) {
        # Input is a ref - use it
        $dump = $input;
        if (ref($dump) ne 'HASH') {
            OIO::Args->die('message'  => 'Argument to pump() is not a hash ref');
        }

    } else {
        # Input is not a ref - convert it
        my @errs;
        local $SIG{__WARN__} = sub { push(@errs, @_); };

        eval "\$dump = $input";

        if ($@ || @errs) {
            my ($err) = split(/ at /, $@ || join(" | ", @errs));
            OIO::Args->die(
                'message'  => 'Failure converting dump string back to hash ref',
                'Error'    => $err,
                'Arg'      => $input);
        }

        # Check that we got a hash ref
        if (ref($dump) ne 'HASH') {
            OIO::Args->die(
                'message'  => 'Argument to pump() did not convert to a hash ref',
                'Arg'      => $input);
        }
    }

    # The class for the object
    my $class = $dump->{'CLASS'};
    if (! $class) {
        OIO::Args->die('message'  => q/'CLASS' key missing in argument to pump()/);
    }

    # Get thread-sharing flag
    my $am_sharing = is_sharing($class);

    # Create a new 'bare' object
    my $self = Object::InsideOut::Util::create_object($class,
                                                      $ID_SUBS{$class}[0]);
    if ($am_sharing) {
        threads::shared::share($self);
    }

    # Store object data
    while (my ($pkg, $data) = each(%{$dump})) {
        next if ($pkg eq 'CLASS');

        # Try to use a class-supplied pumper
        if (my $pumper = $PUMPERS{$pkg}) {
            local $SIG{__DIE__} = 'OIO::trap';
            $pumper->($self, $data);

        } else {
            # Pump in the data ourselves
            while (my ($fld_name, $value) = each(%{$data})) {
                if (my $field = $DUMP_FIELDS{$pkg}{$fld_name}[0]) {
                    if (is_sharing($pkg)) {
                        $value = Object::InsideOut::Util::make_shared($value);
                    }
                    if (ref($field) eq 'HASH') {
                        $field->{$$self} = $value;
                    } else {
                        $field->[$$self] = $value;
                    }
                } else {
                    if ($fld_name =~ /^(HASH|ARRAY)/) {
                        OIO::Args->die(
                            'message' => "Unnamed field encounted in class '$pkg'",
                            'Arg'     => "$fld_name => $value");
                    } else {
                        OIO::Args->die('message' => "Unknown field name for class '$pkg': $fld_name");
                    }
                }
            }
        }
    }

    # Thread support
    if ($am_sharing) {
        # Add thread tracking list for this thread-shared object
        lock(%SHARED);
        if (! exists($SHARED{$class})) {
            $SHARED{$class} = &threads::shared::share({});
        }
        $SHARED{$class}{$$self} = &threads::shared::share([]);
        push(@{$SHARED{$class}{$$self}}, $THREAD_ID);

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

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


### Code Generators ###

# Dynamically creates an AUTOLOAD subroutine
# Called from initialize() only if some Automethods are defined
sub create_AUTOLOAD : PRIVATE
{
    # $AUTOMETHODS    - ref to %AUTOMETHODS
    # $TREE_BOTTOM_UP - ref to %TREE_BOTTOM_UP
    my ($AUTOMETHODS, $TREE_BOTTOM_UP) = @_;

    return sub {
        my $thing = $_[0];
        my $class = ref($thing) || $thing;

        # Extract the base method name from the fully-qualified name
        my ($method) = our $AUTOLOAD =~ /.*::(.*)/;

        # Find an Automethod
        for my $package (@{$TREE_BOTTOM_UP->{$class}}) {
            if (my $automethod = $AUTOMETHODS->{$package}) {
                # Call the Automethod to get a code ref
                local $CALLER::_ = $_;
                local $_ = $method;
                local $SIG{__DIE__} = 'OIO::trap';
                if (my $code = $automethod->(@_)) {
                    # Go to the code ref returned by the Automethod
                    goto &{$code};
                }
            }
        }

        # Failed to AUTOLOAD
        my $type = ref($thing) ? 'object' : 'class';
        OIO::Method->die('message' => "Can't locate $type method '$method' for package '$class'");
    };
}


# Returns a closure back to initialize() that is used to redefine
# UNIVERSAL::can()
sub create_UNIVERSAL_can : PRIVATE
{
    # $univ_can       - ref to the orginal UNIVERSAL::can()
    # $AUTOMETHODS    - ref to %AUTOMETHODS
    # $TREE_BOTTOM_UP - ref to %TREE_BOTTOM_UP
    my ($univ_can, $AUTOMETHODS, $TREE_BOTTOM_UP) = @_;

    return sub {
        my ($thing, $method) = @_;

        # Special handling for 'SUPER::'
        # http://rt.cpan.org/NoAuth/Bug.html?id=14431
        # 'SUPER::' refers to the context of the caller.  Therefore, need to
        # preface 'SUPER::' with the caller's package name.
        if ($method =~ /SUPER::/) {
            my $caller = caller();
            $method =~ s/SUPER::/${caller}::SUPER::/;
        }

        # First, try the original UNIVERSAL::can()
        if (my $code = $univ_can->($thing, $method)) {
            return $code;
        }

        # Next, check with the Automethods
        for my $package (@{$TREE_BOTTOM_UP->{ref($thing) || $thing}}) {
            if (my $automethod = $AUTOMETHODS->{$package}) {
                # Call the Automethod to get a code ref
                local $CALLER::_ = $_;
                local $_ = $_[1];    # Method name
                local $SIG{__DIE__} = 'OIO::trap';
                if (my $code = $automethod->($thing, $method)) {
                    # Use the code ref returned by the Automethod
                    my $method_name = $_[1];
                    return sub {
                        my $self = shift;
                        no strict 'refs';
                        $self->$method_name($thing, $method);
                    };
                }
            }
        }

        return;   # Nothing found
    };
}


# Creates object data accessors for classes
sub create_accessors : PRIVATE
{
    my ($package, $field_ref, $decl) = @_;

    # Parse the accessor declaration
    my $acc_spec;
    {
        my @errs;
        local $SIG{__WARN__} = sub { push(@errs, @_); };

        if ($decl =~ /{/) {
            eval "\$acc_spec = $decl;";
        } else {
            eval "\$acc_spec = { $decl }";
        }

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

    # Get info for accessors
    my ($get, $set, $type, $name);
    while (my ($key, $val) = each(%{$acc_spec})) {
        if ($key =~ /^st.*d/i) {
            $get = 'get_' . $val;
            $set = 'set_' . $val;
        } elsif ($key =~ /^acc|^com|[gs]et/i) {
            if ($key =~ /acc|com|get/i) {
                $get = $val;
            }
            if ($key =~ /acc|com|set/i) {
                $set = $val;
            }
        } elsif ($key =~ /^type$/i) {
            $type = $val;
        } elsif ($key =~ /^name$/i) {
            $name = $val;
        } else {
            OIO::Attribute->die(
                'caller_level' => 3,
                'message'      => "Can't create accessor method for package '$package'",
                'Info'         => "Unknown accessor specifier: $key");
        }
    }

    # Add field info for dump()
    if ($name) {
        $DUMP_FIELDS{$package}{$name} = [ $field_ref, 'Name' ];
        # Done if only 'Name' present
        if (! $get && ! $set) {
            return;
        }
    } elsif ($get) {
        $DUMP_FIELDS{$package}{$get} = [ $field_ref, 'Get' ];
    } elsif ($set) {
        $DUMP_FIELDS{$package}{$set} = [ $field_ref, 'Set' ];
    }

    # Check on accessor names
    my $have_one = 0;
    for my $method ($get, $set) {
        if (defined($method)) {
            if ($method) {
                no strict 'refs';
                # Do not overwrite existing methods
                if (*{$package.'::'.$method}{CODE}) {
                    OIO::Attribute->die(
                        'caller_level' => 3,
                        'message'      => q/Can't create accessor method/,
                        'Info'         => "Method '$method' already exists in class '$package'");
                }
            } else {
                OIO::Attribute->die(
                    'caller_level' => 3,
                    'message'      => "Can't create accessor method for package '$package'",
                    'Info'         => q/Accessor name missing in :Field attribute/,
                    'Attribute'    => "Field( $decl )");
            }
            $have_one++;
        }
    }
    if (! $have_one) {
        OIO::Attribute->die(
            'caller_level' => 3,
            'message'      => "Accessor name missing in :Field attribute in package '$package'",
            'Info'         => q/Need 'GET', 'SET' or 'ACCESSOR' designator/,
            'Attribute'    => "Field( $decl )");
    }

    # Check type and set default
    if ($type) {
        if ($type =~ /^num(ber|eric)?/i) {
            $type = 'NUMERIC';
        } elsif (uc($type) eq 'LIST' || uc($type) eq 'ARRAY') {
            $type = 'ARRAY';
        } elsif (uc($type) eq 'HASH') {
            $type = 'HASH';
        }
    } else {
        $type = 'NONE';
    }

    # Code to be eval'ed into subroutines
    my $code = '';

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

        # Lock the field if sharing
        if (is_sharing($package)) {
            $code .= "    lock(\$field);\n"
        }

        # Add GET portion for combination accessor
        if (defined($get) && $get eq $set) {
            if (ref($field_ref) eq 'HASH') {
                $code .= <<"_COMBINATION_";
        if (\@_ == 1) {
            return (\$field->\{\${\$_[0]}});
        }
_COMBINATION_
            } else {
                $code .= <<"_COMBINATION_";
        if (\@_ == 1) {
            return (\$field->\[\${\$_[0]}]);
        }
_COMBINATION_
            }
            undef($get);  # That it for 'GET'
        }

        # Else check that set was called with at least one arg
        else {
            $code .= <<"_CHECK_ARGS_";
    if (\@_ < 2) {
        OIO::Args->die('message' => q/Missing arg(s) to '$package->$set'/);
    }
_CHECK_ARGS_
        }

        # Add data type checking
        if ($type eq 'NONE') {
            # No data type check required
            $code .= "    my \$arg = \$_[1];\n";

        } elsif ($type eq 'NUMERIC') {
            # One numeric argument
            $code .= <<"_NUMERIC_";
    my \$arg;
    if (! Scalar::Util::looks_like_number(\$arg = \$_[1])) {
        OIO::Args->die(
            'message' => "Bad argument: \$arg",
            'Usage'   => q/Argument to '$package->$set' must be numeric/);
    }
_NUMERIC_

        } elsif ($type eq 'ARRAY') {
            # 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_

        } elsif ($type eq 'HASH') {
            # 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/'$package->$set' requires a hash ref or an even number of args (to make a hash ref)/);
    } else {
        my \@args = \@_;
        shift(\@args);
        my \%args = \@args;
        \$arg = \\\%args;
    }
_HASH_

        } else {
            # One object or ref arg - exact spelling and case required
            $code .= <<"_OTHER_TYPE_";
    my \$arg;
    if (! Object::InsideOut::Util::is_it(\$arg = \$_[1], '$type')) {
        OIO::Args->die(
            'message' => q/Bad argument: Wrong type/,
            'Usage'   => q/Argument to '$package->$set' must be an object or ref of type '$type'/);
    }
_OTHER_TYPE_
        }

        # Add actual 'set' code
        if (ref($field_ref) eq 'HASH') {
            $code .= (is_sharing($package))
                  ? "    \$field->\{\${\$_[0]}} = Object::InsideOut::Util::make_shared(\$arg);\n};\n"
                  : "    \$field->\{\${\$_[0]}} = \$arg;\n};\n";
        } else {
            $code .= (is_sharing($package))
                  ? "    \$field->\[\${\$_[0]}] = Object::InsideOut::Util::make_shared(\$arg);\n};\n"
                  : "    \$field->\[\${\$_[0]}] = \$arg;\n};\n";
        }
    }

    # Create 'get' accessor
    if (defined($get)) {
        # Set up locking code
        my $lock = (is_sharing($package)) ? "    lock(\$field);\n" : '';

        # Build subroutine text
        if (ref($field_ref) eq 'HASH') {
            $code .= <<"_GET_";
*${package}::$get = sub {
$lock    \$field->{\${\$_[0]}};
};
_GET_
        } else {
            $code .= <<"_GET_";
*${package}::$get = sub {
$lock    \$field->[\${\$_[0]}];
};
_GET_
        }
    }

    # Compile the subroutine(s) in the smallest possible lexical scope
    my @errs;
    local $SIG{__WARN__} = sub { push(@errs, @_); };
    {
        my $field = $field_ref;
        eval $code;
    }
    if ($@ || @errs) {
        my ($err) = split(/ at /, $@ || join(" | ", @errs));
        OIO::Internal->die(
            'location'    => [ __PACKAGE__, __FILE__, __LINE__ ],
            'message'     => "Failure creating accessor for class '$package'",
            'Error'       => $err,
            'Declaration' => $decl,
            'Code'        => $code);
    }
}


# Returns a closure back to initialize() that is used to setup CUMULATIVE
# and CUMULATIVE(BOTTOM UP) methods for a particular method name.
sub create_CUMULATIVE : PRIVATE
{
    # $tree      - ref to either %TREE_TOP_DOWN or %TREE_BOTTOM_UP
    # $code_refs - hash ref by package of code refs for a particular method name
    my ($tree, $code_refs) = @_;

    return sub {
        my $class = ref($_[0]) || $_[0];
        my $list_context = wantarray;
        my (@results, @classes);

        # Accumulate results
        for my $pkg (@{$tree->{$class}}) {
            if (my $code = $code_refs->{$pkg}) {
                local $SIG{__DIE__} = 'OIO::trap';
                my @args = @_;
                if (defined($list_context)) {
                    push(@classes, $pkg);
                    if ($list_context) {
                        # List context
                        push(@results, $code->(@args));
                    } else {
                        # Scalar context
                        push(@results, scalar($code->(@args)));
                    }
                } else {
                    # void context
                    $code->(@args);
                }
            }
        }

        # Return results
        if (defined($list_context)) {
            if ($list_context) {
                # List context
                return (@results);
            }
            # Scalar context - returns object
            return (Object::InsideOut::Results->new('VALUES'  => \@results,
                                                    'CLASSES' => \@classes));
        }
    };
}


# Returns a closure back to initialize() that is used to setup CHAINED
# and CHAINED(BOTTOM UP) methods for a particular method name.
sub create_CHAINED : PRIVATE
{
    # $tree      - ref to either %TREE_TOP_DOWN or %TREE_BOTTOM_UP
    # $code_refs - hash ref by package of code refs for a particular method name
    my ($tree, $code_refs) = @_;

    return sub {
        my $thing = shift;
        my $class = ref($thing) || $thing;
        my @args = @_;
        my $list_context = wantarray;
        my @classes;

        # Chain results together
        for my $pkg (@{$tree->{$class}}) {
            if (my $code = $code_refs->{$pkg}) {
                local $SIG{__DIE__} = 'OIO::trap';
                @args = $code->($thing, @args);
                push(@classes, $pkg);
            }
        }

        # Return results
        if (defined($list_context)) {
            if ($list_context) {
                # List context
                return (@args);
            }
            # Scalar context - returns object
            return (Object::InsideOut::Results->new('VALUES'  => \@args,
                                                    'CLASSES' => \@classes));
        }
    };
}


# Returns a 'wrapper' closure back to initialize() that restricts a method
# to being only callable from within its class hierarchy
sub create_RESTRICTED : PRIVATE
{
    my ($package, $method, $code) = @_;
    return sub {
        my $caller = caller();
        if ($caller->isa($package) || $package->isa($caller)) {
            goto &{$code}
        }
        OIO::Method->die('message' => "Can't call restricted method '$package->$method' from class '$caller'");
    };
}


# Returns a 'wrapper' closure back to initialize() that makes a method
# private (i.e., only callable from within its own class).
sub create_PRIVATE : PRIVATE
{
    my ($package, $method, $code) = @_;
    return sub {
        my $caller = caller();
        if ($caller eq $package) {
            goto &{$code}
        }
        OIO::Method->die('message' => "Can't call private method '$package->$method' from class '$caller'");
    };
}


# Redefines a subroutine in this package to make it uncallable from the outside
# world.
sub create_HIDDEN : PRIVATE
{
    my ($package, $method) = @_;

    my $code = <<"_CODE_";
sub ${package}::$method {
    OIO::Method->die('message' => q/Can't call hidden method '$package->$method'/);
}
_CODE_

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

    eval $code;

    if ($@ || @errs) {
        my ($err) = split(/ at /, $@ || join(" | ", @errs));
        OIO::Internal->die(
            'location' => [ __PACKAGE__, __FILE__, __LINE__ ],
            'message'  => "Failure hiding '$package->$method'",
            'Error'    => $err,
            'Code'     => $code);
    }
}

}  # End of package's lexical scope

1;

__END__

=head1 NAME

Object::InsideOut - Comprehensive inside-out object support module

=head1 VERSION

This document describes Object::InsideOut version 1.01.00

=head1 SYNOPSIS

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

     # Numeric field with combined get+set accessor
     my @data :Field('Accessor' => 'data', 'Type' => 'NUMERIC');

     # Takes 'DATA' (or 'data', etc.) as a manatory parameter to ->new()
     my %init_args :InitArgs = (
         'DATA' => {
             'Regex'     => qr/^data$/i,
             'Mandatory' => 1,
             'Type'      => 'NUMERIC',
         },
     )

     # Handle class specific args as part of ->new()
     sub init :Init
     {
         my ($self, $args) = @_;

         $data[$$self] = $args->{'DATA'};
     }
 }

 package My::Class::Sub; {
     use Object::InsideOut qw(My::Class);

     # List field with standard 'get_X' and 'set_X' accessors
     my @info :Field('Standard' => 'info', 'Type' => 'LIST');

     # Takes 'INFO' as an optional list parameter to ->new()
     # Value automatically added to @info array
     # Defaults to [ 'empty' ]
     my %init_args :InitArgs = (
         'INFO' => {
             'Type'    => 'LIST',
             'Field'   => \@info,
             'Default' => 'empty',
         },
     );
 }

 package main;

 my $obj = My::Class::Sub->new('Data' => 69);
 my $info = $obj->get_info();                    # [ 'empty' ]
 my $data = $obj->data();                        # 69
 $obj->data(42);
 $data = $obj->data();                           # 42

 $obj = My::Class::Sub->new('INFO' => 'help', 'DATA' => 86);
 $data = $obj->data();                           # 86
 $info = $obj->get_info();                       # [ 'help' ]
 $obj->set_info(qw(foo bar baz));
 $info = $obj->get_info();                       # [ 'foo', 'bar', 'baz' ]

=head1 DESCRIPTION

This module provides comprehensive support for implementing classes using the
inside-out object model.

This module implements inside-out objects as anonymous scalar references that
are blessed into a class with the scalar containing the ID for the object
(usually a sequence number).  Object data (i.e., fields) are stored within the
class's package in either arrays indexed by the object's ID, or hashes keyed
to the object's ID.

The virtues of the inside-out object model over the I<blessed hash> object
model have been extolled in detail elsewhere.  See the informational links
under L</"SEE ALSO">.  Briefly, inside-out objects offer the following
advantages over I<blessed hash> objects:

=over

=item Encapsulation

Object data is enclosed within the class's code and is accessible only through
the class-defined interface.

=item Field Name Collision Avoidance

Inheritance using I<blessed hash> classes can lead to conflicts if any classes
use the same name for a field (i.e., hash key).  Inside-out objects are immune
to this problem because object data is stored inside each class's package, and
not in the object itself.

=item Compile-time Name Checking

A common error with I<blessed hash> classes is the misspelling of field names:

    $obj->{'coment'} = 'No comment';   # Should be 'comment' not 'coment'

As there is no compile-time checking on hash keys, such errors do not usually
manifest themselves until runtime.

With inside-out objects, data is accessed using methods, the names of which
are checked by the Perl compiler such that any typos are easily caught using
S<C<perl -c>>.

=back

This module offers all the capabilities of L<Class::Std> with the following
additional key advantages:

=over

=item Speed

When using arrays to store object data, Object::InsideOut objects are as
much as 40% faster than I<blessed hash> objects for fetching and setting data,
and even with hashes they are still several percent faster than I<blessed
hash> objects.

For the same types of operations, Object::InsideOut objects are from 2 to 6
times faster than Class::Std objects.

=item Threads

Object::InsideOut is thread safe, and thoroughly supports sharing objects
between threads using L<threads::shared>.  Class::Std is not usable in
threaded applications (or applications that use C<fork> under ActivePerl).

=item Flexibility

Allows control over object ID specification, accessor naming, parameter name
matching, and more.

=item L<mod_perl> and Runtime Loading

Usable from within L<mod_perl>, and supports classes that may be loaded at
runtime (i.e., using S<C<eval { require ...; };>>).

=item Perl 5.6

Usable with Perl 5.6.0 and later.  Class::Std is only usable with Perl 5.8.1
and later.

=item Exception Objects

As recommended in I<Perl Best Practices>, Object::InsideOut uses
L<Exception::Class> for handling errors in an OO-compatible manner.

=item Object Serialization

Object dumping and reloading can be accomplished in either an automated
fashion or through the use of class-supplied subroutines.  Class::Std provides
a global C<_DUMP> method, but no reloading capability.

=back

=head2 Class Declarations

To use this module, your classes will start with S<C<use Object::InsideOut;>>:

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

Sub-classes inherit from base classes by telling Object::InsideOut what the
parent class is:

    package My::Sub {
        use Object::InsideOut qw(My::Parent);
        ...
    }

Multiple inheritance is also supported:

    package My::Project {
        use Object::InsideOut qw(My::Class Another::Class);
        ...
    }

There is no need for S<C<use base ...>>, or to set up C<@ISA> arrays.  (In
fact, you shouldn't do either:  Object::InsideOut acts as a replacement for
the C<base> pragma.)  Object::InsideOut loads the parent module(s), calls
their C<import> functions, and sets up the sub-class's @ISA array.

If a parent class takes parameters, enclose them in an array ref (mandatory)
following the name of the parent class:

    package My::Project {
        use Object::InsideOut 'My::Class'      => [ 'param1', 'param2' ],
                              'Another::Class' => [ 'param' ];
        ...
    }

=head2 Field Declarations

Object data fields consist of arrays within a class's package into which data
are stored using the object's ID as the array index.  An array is declared as
being an object field by following its declaration with the C<:Field>
attribute:

    my @info :Field;

Object data fields may also be hashes:

    my %data :Field;

However, as array access is as much as 40% faster than hash access, you should
stick to using arrays.  (See L</"Object ID"> concerning when hashes may be
required.)

(The case of the word I<Field> does not matter, but by convention should not
be all lowercase.)

=head2 Object Creation

Objects are created using the C<new> method which is exported by
Object::InsideOut to each class:

    my $obj = My::Class->new();

Classes do not implement their own C<new> method.  Class-specific object
initialization actions may be handled by C<:Init> labelled methods (see
L</"Object Initialization">).

Parameters are passed in as combinations of S<C<key =E<gt> value>> pairs
and/or hash refs:

    my $obj = My::Class->new('param1' => 'value1');
        # or
    my $obj = My::Class->new({'param1' => 'value1'});
        # or even
    my $obj = My::Class->new(
        'param_X' => 'value_X',
        'param_Y' => 'value_Y',
        {
            'param_A' => 'value_A',
            'param_B' => 'value_B',
        },
        {
            'param_Q' => 'value_Q',
        },
    );

Additionally, parameters can be segregated in hash refs for specific classes:

    my $obj = My::Class->new(
        'foo' => 'bar',
        'My::Class'      => { 'param' => 'value' },
        'Parent::Class'  => { 'data'  => 'info'  },
    );

The initialization methods for both classes in the above will get S<C<'foo'
=E<gt> 'bar'>>, C<My::Class> will also get S<C<'param' =E<gt> 'value'>>, and
C<Parent::Class> will also get S<C<'data' =E<gt> 'info'>>.  In this scheme,
class-specific parameters will override general parameters specified at a
higher level:

    my $obj = My::Class->new(
        'default' => 'bar',
        'Parent::Class'  => { 'default' => 'baz' },
    );

C<My::Class> will get S<C<'default' =E<gt> 'bar'>>, and C<Parent::Class> will
get S<C<'default' =E<gt> 'baz'>>.

Calling C<new> on an object works, too, and operates the same as calling
C<new> for the class of the object (i.e., C<$obj-E<gt>new()> is the same as
C<ref($obj)-E<gt>new()>).

NOTE: You cannot create objects from Object::InsideOut itself:

    # This is an error
    # my $obj = Object::InsideOut->new();

In this way, Object::InsideOut is not an object class, but functions more like
a pragma.

=head2 Object Cloning

Copies of objects can be created using the C<clone> method which is exported
by Object::InsideOut to each class:

    my $obj2 = $obj->clone();

=head2 Object Initialization

Object initialization is accomplished through a combination of an C<:InitArgs>
labelled hash (explained in detail in the L<next section|/"Object
Initialization Argument Specifications">), and an C<:Init> labelled
subroutine.

The C<:InitArgs> labelled hash specifies the parameters to be extracted from
the argument list supplied to the C<new> method.  These parameters are then
sent to the C<:Init> labelled subroutine for processing:

    package My::Class; {
        my @my_field :Field;

        my %init_args :InitArgs = (
            'MY_PARAM' => qr/MY_PARAM/i,
        );

        sub _init :Init
        {
            my ($self, $args) = @_;

            if (exists($args->{'MY_PARAM'})) {
                $my_field[$$self] = $args->{'MY_PARAM'};
            }
        }
    }

    package main;

    my $obj = My::Class->new('my_param' => 'data');

(The case of the words I<InitArgs> and I<Init> does not matter, but by
convention should not be all lowercase.)

This C<:Init> labelled subroutine will receive two arguments:  The newly
created object requiring further initialization (i.e., C<$self>), and a hash
ref of supplied arguments that matched C<:InitArgs> specifications.  Data
processed by the subroutine can be placed into the class's field arrays
(hashes) using the object's ID (i.e., C<$$self>).

=head2 Object Initialization Argument Specifications

The parameters to be handled by the C<new> method are specified in a hash that
is labelled with the C<:InitArgs> attribute.

The simplest parameter specification is just a tag:

    my %init_args :InitArgs = (
        'DATA' => '',
    );

In this case, if a S<C<key =E<gt> value>> pair with an exact match of C<DATA>
for the key is found in the arguments sent to the C<new> method, then
S<C<'DATA' =E<gt> value>> will be included in the argument hash ref sent to
the C<:Init> labelled subroutine.

Rather than counting on exact matches, regular expressions can be used to
specify the parameter:

    my %init_args :InitArgs = (
        'Param' => qr/^PARA?M$/i,
    );

In this case, the argument key could be any of the following: PARAM, PARM,
Param, Parm, param, parm, and so on.  If a match is found, then S<C<'Param'
=E<gt> value>> is sent to the C<:Init> subroutine.  Note that the C<:InitArgs>
hash key is substituted for the original argument key.  This eliminates the
need for any parameter key pattern matching within the C<:Init> subroutine.

With more complex parameter specifications, the syntax changes.  Mandatory
parameters are declared as follows:

    my %init_args :InitArgs = (
        # Mandatory parameter requiring exact matching
        'INFO' => {
            'Mandatory' => 1,
        },
        # Mandatory parameter with pattern matching
        'input' => {
            'Regex'     => qr/^in(?:put)?$/i,
            'Mandatory' => 1,
        },
    );

If a mandatory parameter is missing from the argument list to C<new>, an error
is generated.

For optional parameters, defaults can be specified:

    my %init_args :InitArgs = (
        'LEVEL' => {
            'Regex'   => qr/^lev(?:el)?|lvl$/i,
            'Default' => 3,
        },
    );

The parameter's type can also be specified:

    my %init_args :InitArgs = (
        'LEVEL' => {
            'Regex'   => qr/^lev(?:el)?|lvl$/i,
            'Default' => 3,
            'Type'    => 'Numeric',
        },
    );

Available types are C<Numeric> (or C<Num> or C<Number> - case-insensitive),
C<List> (case-insensitive), a class (e.g., C<My::Class>), or a reference type
(e.g., 'HASH', 'ARRAY', etc.).  The C<List> type allows a single value (that
is then placed in an array ref) or an array ref.  For class and ref types,
exact case and spelling are required.

You can specify automatic processing for a parameter's value such that it is
placed directly info a field hash and not sent to the C<:Init> subroutine:

    my @hosts :Field;

    my %init_args :InitArgs = (
        'HOSTS' => {
            # Allow 'host' or 'hosts' - case-insensitive
            'Regex'     => qr/^hosts?$/i,
            # Mandatory parameter
            'Mandatory' => 1,
            # Allow single value or array ref
            'Type'      => 'List',
            # Automatically put the parameter into @hosts
            'Field'     => \@hosts,
        },
    );

In this case, when the host parameter is found, it is automatically put into
the C<@hosts> array, and a S<C<'HOSTS' =E<gt> value>> pair is B<not> sent to
the C<:Init> subroutine.  In fact, if you specify fields for all your
parameters, then you don't even need to have an C<:Init> subroutine!  All the
work will be taken care of for you.

(In the above, I<Regex> may be I<Regexp> or just I<Re>, and I<Default> may be
I<Defaults> or I<Def>.  They and the other specifier keys are
case-insensitive, as well.)

=head2 Automatic Accessor Generation

As part of the L</"Field Declarations">, you can optionally specify the
automatic generation of accessor methods.  You can specify the generation of a
pair of I<standard-named> accessor methods (i.e., prefixed by I<get_> and
I<set_>):

    my @data :Field('Standard' => 'data');

The above results in Object::InsideOut automatically generating accessor
methods named C<get_data> and C<set_data>.  (The keyword C<Standard> is
case-insensitive, and can be abbreviated to C<Std>.)

You can also separately specify the I<get> and/or I<set> accessors:

    my @name :Field('Get' => 'name', 'Set' => 'change_name');
        # or
    my @name :Field('Get' => 'get_name');
        # or
    my @name :Field('Set' => 'new_name');

For the above, you specify the full name of the accessor(s) (i.e., no prefix
is added to the given name(s)).  (The C<Get> and C<Set> keywords are
case-insensitive.)

You can specify the automatic generation of a combined I<get/set> accessor
method:

    my @comment :Field('Accessor' => 'comment');

(The keyword C<Accessor> is case-insensitive, and can be abbreviated to
C<Acc> or can be specified as C<get+set> or C<Combined> or C<Combo>.)  The
above generates a method called C<comment> that is equivalent to:

    sub comment
    {
        my ($self, $cmt) = @_;

        if (defined($cmt)) {
            return ($comment{$$self} = $cmt);
        }

        return ($comment{$$self});
    }

For any of the automatically generated methods that perform I<set> operations,
the method's return value is the value being set.

Type-checking for the I<set> operation can be specified, as well:

    my @level :Field('Accessor' => 'level', 'Type' => 'Numeric');

Available types are C<Numeric> (or C<Num> or C<Number> - case-insensitive),
C<List> or C<Array> (case-insensitive), C<Hash> (case-insensitive), a class
(e.g., C<My::Class>), or a reference type (e.g., 'CODE').  For class and ref
types, exact case and spelling are required.

The C<List/Array> type permits the accessor to accept multiple value (that are
then placed in an array ref) or a single array ref.  The C<Hash> type allows
multiple S<C<key =E<gt> value>> pairs (that are then placed in a hash ref) or
a single hash ref.

Due to limitations in the Perl parser, you cannot use line wrapping with the
C<:Field> attribute:

    # This doesn't work
    # my @level :Field('Get'  => 'level',
    #                  'Set'  => 'set_level',
    #                  'Type' => 'Num');

    # Must be all on one line
    my @level :Field('Get' =>'level', 'Set' => 'set_level', 'Type' => 'Num');

=head2 Object ID

By default, the ID of an object is derived from a sequence counter for the
object's class hierarchy.  This should suffice for nearly all cases of class
development.  If there is a special need for the module code to control the
object ID (see L<Math::Random::MT::Auto> as an example), then an C<:ID>
labelled subroutine can be specified:

    sub _id :ID
    {
        my $class = $_[0];

        # Determine a unique object ID
        ...

        return ($id);
    }

The ID returned by your subroutine can be any kind of I<regular> scalar (e.g.,
a string or a number).  However, if the ID is something other than a
low-valued integer, then you will have to architect all your classes using
hashes for the object fields.

Within any class hierachy only one class may specify an C<:ID> subroutine.

=head2 Object Replication

Object replication occurs explicitly when the C<clone> method is called on an
object, and implicitly when threads are created in a threaded application.  In
nearly all cases, Object::InsideOut will take care of all the details for you.

In rare cases, a class may require special handling for object replication.
It must then provide a subroutine labelled with the C<:Replicate> attribute.
This subroutine will be sent two objects:  The parent and the clone:

    sub _replicate :Replicate
    {
        my ($parent, $clone) = @_;

        # Special object replication processing
    }

In the case of thread cloning, the C<$parent> object is just an un-blessed
anonymous scalar reference that contains the ID for the object in the parent
thread.

The C<:Replicate> subroutine only needs to deal with the special replication
processing:  Object::InsideOut will handle all the other details.

=head2 Object Destruction

Object::InsideOut exports a C<DESTROY> method to each class that deletes an
object's data from the object field arrays (hashes).  If a class requires
additional destruction processing (e.g., closing filehandles), then it must
provide a subroutine labelled with the C<:Destroy> attribute.  This subroutine
will be sent the object that is being destroyed:

    sub _destroy :Destroy
    {
        my $obj = $_[0];

        # Special object destruction processing
    }

The C<:Destroy> subroutine only needs to deal with the special destruction
processing:  The C<DESTROY> method will handle all the other details of object
destruction.

=head2 Automethods

There are significant issues related to Perl's C<AUTOLOAD> mechanism.  Read
Damian Conway's description in L<Class::Std/"C<AUTOMETHOD()>"> for more
details.  Object::InsideOut handles these issues in the same manner.

Classes requiring C<AUTOLOAD> capabilities must provided a subroutine labelled
with the C<:Automethod> attribute.  The C<:Automethod> subroutine will be
called with the object and the arguments in the original method call (the same
as for C<AUTOLOAD>).  The C<:Automethod> subroutine should return either a
subroutine reference that implements the requested method's functionality, or
else C<undef> to indicate that it doesn't know how to handle the request.

The name of the method being called is passed as C<$_> instead of
C<$AUTOLOAD>, and does I<not> have the class name prepended to it.  If the
C<:Automethod> subroutine also needs to access the C<$_> from the caller's
scope, it is available as C<$CALLER::_>.

    sub _automethod :Automethod
    {
        my $self = shift;
        my @args = @_;

        my $method_name = $_;

        # If method can be handled by this class
        if (...) {
            my $handler = sub { .... };

            return ($handler);
        }

        # This class cannot handle the method request
        return;
    }

=head2 Cumulative Methods

As with C<Class::Std>, Object::InsideOut provides a mechanism for creating
methods whose effects accumulate through the class hierarchy.  See
L<Class::Std/"C<:CUMULATIVE()>"> for details.  Such methods are tagged with
the C<:Cumulative> attribute (or S<C<:Cumulative(top down)>>), and propogate
from the I<top down> through the class hierarchy (i.e., from the base classes
down through the child classes).  If tagged with S<C<:Cumulative(bottom up)>>,
they will propogated from the object's class upwards through the parent
classes.

Note that this directionality is the reverse of Class::Std which defaults to
bottom up, and uses S<I<BASE FIRST>> to mean from the base classes downward
through the children.  (I eschewed the use of the term S<I<BASE FIRST>> because I
felt it was ambiguous:  I<base> could refer to the base classes at the top of
the hierarchy, or the child classes at the base (i.e., bottom) of the
hierarchy.)

=head2 Chained Methods

In addition to C<:Cumulative>, Object::InsideOut provides a way of creating
methods that are chained together so that their return values are passed as
input arguments to other similarly named methods in the same class hierarchy.

For example, imagine you had a method called C<format_name> that formats some
text for display:

    package Subscriber; {
        use Object::InsideOut;

        sub format_name {
            my ($self, $name) = @_;

            # Strip leading and trailing whitespace
            $name =~ s/^\s+//;
            $name =~ s/\s+$//;

            return ($name);
        }
    }

And elsewhere you have a second class that formats the case of names:

    package Person; {
        use Lingua::EN::NameCase qw(nc);
        use Object::InsideOut;

        sub format_name {
            my ($self, $name) = @_;

            # Attempt to properly case names
            return (nc($name));
        }
    }

And you decide that you'd like to perform some formatting of your own, and
then have all the parent methods apply their own formatting.  Normally, if you
have a single parent class, you'd just call the method directly with
C<$self->SUPER::format_name($name)>, but if you have more than one parent
class you'd have to explicitly call each method directly:

    package Customer; {
        use Object::InsideOut qw(Person Subscriber);

        sub format_name {
            my ($self, $name) = @_;

            # Compress all whitespace into a single space
            $name =~ s/\s+/ /g;

            $name = $self->Subscriber::format_name($name);
            $name = $self->Person::format_name($name);

            return $name;
        }
    }

With Object::InsideOut you'd add the C<:Chained> attribute to each class's
C<format_name> method, and the methods will be chained together automatically:

    package Subscriber; {
        use Object::InsideOut;

        sub format_name :Chained {
            my ($self, $name) = @_;

            # Strip leading and trailing whitespace
            $name =~ s/^\s+//;
            $name =~ s/\s+$//;

            return ($name);
        }
    }

    package Person; {
        use Lingua::EN::NameCase qw(nc);
        use Object::InsideOut;

        sub format_name :Chained {
            my ($self, $name) = @_;

            # Attempt to properly case names
            return (nc($name));
        }
    }

    package Customer; {
        use Object::InsideOut qw(Person Subscriber);

        sub format_name :Chained {
            my ($self, $name) = @_;

            # Compress all whitespace into a single space
            $name =~ s/\s+/ /g;

            return ($name);
        }
    }

So passing in someone's name to C<format_name> in C<Customer> would cause
leading and trailing whitespace to be removed, then the name to be properly
cased, and finally whitespace to be compressed to a single space.  The
resulting C<$name> would be returned to the caller.

The default direction is to chain methods from the base classes at the top of
the class hierarchy down through the child classes.  You may use the attribute
S<C<:Chained(top down)>> to make this more explicit.

If you label the method with the S<C<:Chained(bottom up)>> attribute, then the
chained methods are called starting with the object's class and working
upwards through the class hierarchy, similar to how S<C<:Cumulative(bottom
up)>> works.

=head2 Object Serialization

=over

=item my $hash_ref = $obj->dump();

=item my $string = $obj->dump(1);

Object::InsideOut exports a method called C<dump> to each class that returns
either a hash or string representation of the object that invokes the method.

The hash representation is returned when C<dump> is called without arguments.
The hash ref that is returned has a key named C<CLASS> whose value is the name
of the object's class.  Next, it contains keys for each of the classes that
make up the object's hierarchy The values for those keys are hash refs
containing S<C<key =E<gt> value>> pairs for the object's fields.  The name for
a field can be specified as part of the L<field declaration|/"Field
Declarations"> using the C<NAME> keyword:

    my @data :Field('Name' => 'data');

If the C<NAME> keyword is not present, then the name for a field will be
either the tag from the C<:InitArgs> array that is associated with the field,
its I<get> method name, its I<set> method name, or, failing all that, a string
of the form C<ARRAY(0x...)> or C<HASH(0x...)>.

When called with a I<true> argument, C<dump> returns a string version of the
hash representation using L<Data::Dumper>.

=item my $obj = Object::InsideOut::pump($data);

C<Object::InsideOut::pump> takes the output from the C<dump> method, and
returns an object that is created using that data.  If C<$data> is the hash
ref returned by using C<$obj-E<gt>dump()>, then the data is inserted directly
into the corresponding fields for each class in the object's class hierarchy.
If If C<$data> is the string returned by using C<$obj-E<gt>dump(1)>, then it
is C<eval>ed to turn it into a hash ref, and then processed as above.

If any of an object's fields are dumped to field name keys of the form
C<ARRAY(0x...)> or C<HASH(0x...)> (see above), then the data will not be
reloadable using C<Object::InsideOut::pump>.  To overcome this problem, the
class developer must either add C<Name> keywords to the C<:Field> declarations
(see above), or provide a C<:Dumper>/C<:Pumper> pair of subroutines as
described below.

=item C<:Dumper> Subroutine Attribute

If a class requires special processing to dump its data, then it can provide a
subroutine labelled with the C<:Dumper> attribute.  This subroutine will be
sent the object that is being dumped.  It may then return any type of scalar
the developer deems appropriate.  Most likely this would be a hash ref
containing S<C<key =E<gt> value>> pairs for the object's fields.  For example,

    my @data :Field;

    sub _dump :Dumper
    {
        my $obj = $_[0];

        my %field_data;
        $field_data{'data'} = $data[$$obj];

        return (\%field_data);
    }

Just be sure not to call your C<:Dumper> subroutine C<dump> as that is the
name of the dump method exported by Object::InsideOut as explained above.

=item C<:Pumper> Subroutine Attribute

If a class supplies a C<:Dumper> subroutine, it will most likely need to
provide a complementary C<:Pumper> labelled subroutine that will be used as
part of creating an object from dumped data using
C<Object::InsideOut::pump()>.  The subroutine will be supplied the new object
that is being created, and whatever scalar was returned by the C<:Dumper>
subroutine.  The corresponding C<:Pumper> for the example C<:Dumper> above
would be:

    sub _pump :Pumper
    {
        my ($obj, $field_data) = @_;

        $data[$$obj] = $field_data->{'data'};
    }

=back

=head2 Restricted and Private Methods

Access to certain methods can be narrowed by use of the C<:Restricted> and
C<:Private> attributes.  C<:Restricted> methods can only be called from within
the class's hierarchy.  C<:Private> methods can only be called from within the
method's class.

Without the above attributes, most methods have I<public> access.  If desired,
you may explicitly label them with the C<:Public> attribute.

=head2 Hidden Methods

For subroutines marked with the following attributes:

=over

=item :ID

=item :Init

=item :Replicate

=item :Destroy

=item :Automethod

=item :Dumper

=item :Pumper

=back

Object::InsideOut normally renders them uncallable (hidden) to class and
application code (as they should normally only be needed by Object::InsideOut
itself).  If needed, this behavior can be overridden by adding the C<PUBLIC>,
C<RESTRICTED> or C<PRIVATE> keywords following the attribute:

    sub _init :Init(private)    # Callable from within this class
    {
        my ($self, $args) = @_;

        ...
    }

NOTE:  A bug in Perl 5.6.0 prevents using these access keywords.  As such,
subroutines marked with the above attributes will be left with I<public>
access.

NOTE:  The above cannot be accomplished by using the corresponding attributes.
For example:

    # sub _init :Init :Private    # Wrong syntax - doesn't work

=head2 Object Coercion

As with C<Class::Std>, Object::InsideOut provides support for various forms of
object coercion through the C<overload> mechanism.  See
L<Class::Std/"C<:STRINGIFY>"> for details.  The following attributes are
supported:

=over

=item :Stringify

=item :Numerify

=item :Boolify

=item :Arrayify

=item :Hashify

=item :Globify

=item :Codify

=back

Coercing an object to a scalar (C<:Scalarify>) is not supported as C<$$obj> is
the ID of the object and cannot be overridden.

=head1 THREAD SUPPORT

For Perl 5.8.0 and later, this module fully supports threads (i.e., is thread
safe).  For Perl 5.8.1 and later, this module supports the sharing of
Object::InsideOut objects between threads using L<threads::shared>.

To use Object::InsideOut in a threaded application, you must put S<C<use
threads;>> at the beginning of the application.  (The use of S<C<require
threads;>> after the program is running is not supported.)  If object sharing
it to be utilized, then S<C<use threads::shared;>> should follow.

If you just S<C<use threads;>>, then objects from one thread will be copied
and made available in a child thread.

The addition of S<C<use threads::shared;>> in and of itself does not alter the
behavior of Object::InsideOut objects.  The default behavior is to I<not>
share objects between threads (i.e., they act the same as with S<C<use
threads;>> alone).

To enable the sharing of objects between threads, you must specify which
classes will be involved with thread object sharing.  There are two methods
for doing this.  The first involves setting a C<::shared> variable for the
class prior to its use:

    use threads;
    use threads::shared;

    $My::Class::shared = 1;
    use My::Class;

The other method is for a class to add a C<:SHARED> flag to its S<C<use
Object::InsideOut ...>> declaration:

    package My::Class; {
        use Object::InsideOut ':SHARED';
        ...
    }

When either sharing flag is set for one class in an object hierarchy, then all
the classes in the hierarchy are affected.

If a class cannot support thread object sharing (e.g., one of the object
fields contains code refs [which Perl cannot share between threads]), it
should specifically declare this fact:

    package My::Class; {
        use Object::InsideOut ':NOT_SHARED';
        ...
    }

However, you cannot mix thread object sharing classes with non-sharing
classes in the same class hierarchy:

    use threads;
    use threads::shared;

    package My::Class; {
        use Object::InsideOut ':SHARED';
        ...
    }

    package Other::Class; {
        use Object::InsideOut ':NOT_SHARED';
        ...
    }

    package My::Derived; {
        use Object::InsideOut qw(My::Class Other::Class);   # ERROR!
        ...
    }

Here is a complete example with thread object sharing enabled:

    use threads;
    use threads::shared;

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

        # One list-type field
        my @data : Field('Accessor' => 'data', 'Type' => 'List');
    }

    package main;

    # New object
    my $obj = My::Class->new();

    # Set the object's 'data' field
    $obj->data(qw(foo bar baz));

    # Print out the object's data
    print(join(', ', @{$obj->data()}), "\n");              # "foo, bar, baz"

    # Create a thread and manipulate the object's data
    my $rc = threads->create(
            sub {
                # Read the object's data
                my $data = $obj->data();
                # Print out the object's data
                print(join(', ', @{$data}), "\n");         # "foo, bar, baz"
                # Change the object's data
                $obj->data(@$data[1..2], 'zooks');
                # Print out the object's modified data
                print(join(', ', @{$obj->data()}), "\n");  # "bar, baz, zooks"
                return (1);
            }
        )->join();

    # Show that the changes in the object are visible in the parent thread
    # I.e., this shows that the object was indeed shared between threads
    print(join(', ', @{$obj->data()}), "\n");              # "bar, baz, zooks"

=head1 USAGE WITH C<require> and C<mod_perl>

Prior to version 1.00.00, Object::InsideOut contained a subroutine
(C<Object::InsideOut::INITIALIZE()>) to handle package initialization for use
when loading packages/classes at runtime using C<require>, or when using
L<mod_perl>.

Initialization under L<mod_perl> and with runtime loaded classes is now
performed automatically.  Therefore, this subroutine is no longer required
(i.e., deprecated), and is currently just a I<no-op>.

=head1 DIAGNOSTICS

This module uses C<Exception::Class> for reporting errors.  The base error
class for this module is C<OIO>.

    my $obj;
    eval { $obj = My::Class->new(); };
    if (my $e = OIO->caught()) {
        print(STDERR "Failure creating object: $e\n");
        exit(1);
    }

=over

=item *Invalid ARRAY/HASH attribute

Forgot to 'use Object::InsideOut qw(Parent::Class ...);'

=back

=head1 BUGS AND LIMITATIONS

You cannot overload an object to a scalar context (i.e., can't C<:SCALARIFY>).

You cannot use two instances of the same class with mixed thread object
sharing in same application.

Cannot use attributes on I<subroutine stubs> (i.e., forward declaration
without later definition) with C:<:Automethod>:

    package My::Class; {
        sub method : Private;   # Will not work

        sub _automethod : Automethod
        {
            # Code to handle call to 'method' stub
        }
    }


Due to limitations in the Perl parser, you cannot use line wrapping with the
C<:Field> attribute.

If a I<set> accessor's type is C<SCALAR>, then it can store any inside-out
object type in it.  If it is C<HASH>, then it can store any I<ordinary> object
type.

If you save an object inside another object when thread-sharing, you must
rebless it when you get it out:

    my $bb = BB->new();
    my $aa = AA->new();
    $aa->save($bb);
    my $cc = $aa->get();
    bless($cc, 'BB');

For Perl 5.8.1 through 5.8.4, a Perl bug produces spurious warning messages
when threads are destroyed.  These messages are innocuous, and can be
suppressed by adding the following to your application code:

    $SIG{__WARN__} = sub {
            if ($_[0] !~ /^Attempt to free unreferenced scalar/) {
                print(STDERR @_);
            }
        };

It is known that thread support is broken in ActiveState Perl 5.8.4 on
Windows.  (It is not know which other version of ActivePerl may be affected.)
The best solution is to upgrade your version of ActivePerl.  Barring that, you
can tell CPAN to I<force> the installation of Object::InsideOut, and use it in
non-threaded applications.

Please submit any bugs, problems, suggestions, patches, etc. to:
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Object-InsideOut>

=head1 REQUIREMENTS

Perl 5.6.0 or later

L<Exception::Class> v1.22 or later

L<Scalar::Util> v1.10 or later.  It is possible to install a I<pure perl>
version of Scalar::Util, however, the version of C<refaddr> that is thus
available is unusable.  You'll need to upgrade your version of Scalar::Util to
one that supports its C<XS> code.

L<Test::More> v0.50 or later (for installation)

L<Data::Dumper>

=head1 TO DO

Improve these docs.

Improve test suite.

=head1 SEE ALSO

Inside-out Object Model:
L<http://www.perlmonks.org/index.pl?node_id=219378>,
L<http://www.perlmonks.org/index.pl?node_id=483162>,
Chapters 15 and 16 of I<Perl Best Practices> by Damian Conway

The Rationale for Object::InsideOut:
L<http://www.perlmonks.org/index.pl?node_id=504425>

Object::InsideOut Discussion Forum on CPAN:
L<http://www.cpanforum.com/dist/Object-InsideOut>

=head1 ACKNOWLEDGEMENTS

Abigail S<E<lt>perl AT abigail DOT nlE<gt>> for inside-out objects in general.

Damian Conway for Class::Std.

David A. Golden S<E<lt>david AT dagolden DOT comE<gt>> for thread handling for
inside-out objects.

Dan Kubb S<E<lt>dan.kubb-cpan AT autopilotmarketing DOT comE<gt>> for
C<:Chained> methods.

=head1 AUTHOR

Jerry D. Hedden, S<E<lt>jdhedden AT 1979 DOT usna DOT comE<gt>>

=head1 COPYRIGHT AND LICENSE

Copyright 2005 Jerry D. Hedden. All rights reserved.

This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.

=cut
