File Coverage

blib/lib/Class/EHierarchy.pm

Criterion	Covered	Total	%
statement	699	798	87.5
branch	221	318	69.5
condition	36	69	52.1
subroutine	88	88	100.0
pod	25	25	100.0
total	1069	1298	82.3

# Class::EHierarchy -- Base class for hierarchally ordered objects
#
# (c) 2017, Arthur Corliss
#
# $Id: lib/Class/EHierarchy.pm, 2.01 2019/05/23 07:29:49 acorliss Exp $
#
#    This software is licensed under the same terms as Perl, itself.
#    Please see http://dev.perl.org/licenses/ for more information.
#
#####################################################################

#####################################################################
#
# Environment definitions
#
#####################################################################

package Class::EHierarchy;

use 5.008003;

use strict;
use warnings;
use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS);
use base qw(Exporter);
use Carp;
use Scalar::Util qw(weaken);

($VERSION) = ( q$Revision: 2.01 $ =~ /(\d+(?:\.(\d+))+)/sm );

# Ordinal indexes for the @objects element records
use constant CEH_OREF    => 0;
use constant CEH_PID     => 1;
use constant CEH_PKG     => 2;
use constant CEH_CLASSES => 3;
use constant CEH_CREF    => 4;

# Ordinal indexes for the @properties element records
use constant CEH_PATTR => 0;
use constant CEH_PNAME => 1;
use constant CEH_PPKG  => 1;
use constant CEH_PVAL  => 2;

# Property attribute masks
use constant CEH_PATTR_SCOPE => 7;
use constant CEH_PATTR_TYPE  => 504;

# Property attribute scopes
use constant CEH_PUB   => 1;
use constant CEH_RESTR => 2;
use constant CEH_PRIV  => 4;

# Property attribute types
use constant CEH_SCALAR => 8;
use constant CEH_ARRAY  => 16;
use constant CEH_HASH   => 32;
use constant CEH_CODE   => 64;
use constant CEH_REF    => 128;
use constant CEH_GLOB   => 256;

# Property flags
use constant CEH_NO_UNDEF => 512;

@EXPORT    = qw();
@EXPORT_OK = qw(CEH_PUB CEH_RESTR CEH_PRIV CEH_SCALAR CEH_ARRAY
    CEH_HASH CEH_CODE CEH_REF CEH_GLOB CEH_NO_UNDEF _declProperty
    _declMethod );
%EXPORT_TAGS = ( all => [@EXPORT_OK] );

#####################################################################
#
# Module code follows
#
#####################################################################

##########################################################
# Hierarchal code support
##########################################################

{

    # Array of object references and metadata
    my @objects;

    # Array of recycled IDs availabe for use
    my @recoveredIDs;

    sub _dumpObjects {

        # Purpose:  Provides a list of objects
        # Returns:  List of refs
        # Usage:    @objects = _dumpObjects();

        return map { $$_[CEH_OREF] } grep {defined} @objects;
    }

    sub _getID {

        # Purpose:  Generates and assigns a unique ID to the passed
        #           object, and initializes the internal records
        # Returns:  Integer
        # Usage:    $id = _genID();

        my $obj = CORE::shift;
        my $id = @recoveredIDs ? CORE::shift @recoveredIDs : $#objects + 1;

        $$obj                      = $id;
        $objects[$id]              = [];
        $objects[$id][CEH_CREF]    = [];
        $objects[$id][CEH_CLASSES] = [];
        $objects[$id][CEH_OREF]    = $obj;
        $objects[$id][CEH_PKG]     = ref $obj;
        weaken( $objects[$$obj][CEH_OREF] );

        $id = '0 but true' if $id == 0;

        # Build object class list
        {
            no strict 'refs';

            my ( $isaref, $tclass, $nclass, @classes, $n, $l );
            my $class = ref $obj;

            # Get the first level of classes we're subclassed from
            $isaref = *{"${class}::ISA"}{ARRAY};
            $isaref = [] unless defined $isaref;
            foreach $tclass (@$isaref) {
                CORE::push @classes, $tclass
                    if $tclass ne __PACKAGE__
                        and "$tclass"->isa(__PACKAGE__);
            }

            # Now, recurse into parent classes.
            $n = 0;
            $l = scalar @classes;
            while ( $n < $l ) {
                foreach $tclass ( @classes[ $n .. ( $l - 1 ) ] ) {
                    $isaref = *{"${tclass}::ISA"}{ARRAY};
                    $isaref = [] unless defined $isaref;
                    foreach $nclass (@$isaref) {
                        CORE::push @classes, $nclass
                            if $nclass ne __PACKAGE__
                                and "$nclass"->isa(__PACKAGE__);
                    }
                }
                $n = scalar @classes - $l + 1;
                $l = scalar @classes;
            }

            # Add our current class
            CORE::push @classes, $class;

            # Save the list
            foreach (@classes) { _addClass( $obj, $_ ) }
        }

        return $id;
    }

    sub _delID {

        # Purpose:  Recovers the ID for re-use while deleting the
        #           old data structures
        # Returns:  Boolean
        # Usage:    _recoverID($id);

        my $obj      = CORE::shift;
        my $pid      = $objects[$$obj][CEH_PID];
        my @children = @{ $objects[$$obj][CEH_CREF] };

        # Have the parent disown this child
        _disown( $objects[$pid][CEH_OREF], $obj ) if defined $pid;
        _disown( $obj, $objects[$_][CEH_OREF] ) if @children;

        # Clean up internal data structures
        $objects[$$obj] = undef;
        CORE::push @recoveredIDs, $$obj;

        return 1;
    }

    sub isStale {

        # Purpose:  Checks to see if the object reference is
        #           stale
        # Returns:  Boolean
        # Usage:    $rv = $obj->isStale;

        my $obj = CORE::shift;

        return not( defined $obj
            and defined $objects[$$obj]
            and defined $objects[$$obj][CEH_OREF]
            and $obj eq $objects[$$obj][CEH_OREF] );
    }

    sub _addClass {

        # Purpose:  Records a super class for the object
        # Returns:  Boolean
        # Usage:    $rv = _addClass($obj, $class);

        my $obj   = CORE::shift;
        my $class = CORE::shift;

        CORE::push @{ $objects[$$obj][CEH_CLASSES] }, $class
            if defined $class
                and not grep /^$class$/s, @{ $objects[$$obj][CEH_CLASSES] };

        return 1;
    }

    sub _getClasses {

        # Purpose:  Returns a list of classes
        # Returns:  Array
        # Usage:    @classes = _getClasses($obj);

        my $obj = CORE::shift;

        return @{ $objects[$$obj][CEH_CLASSES] };
    }

    sub _adopt {

        # Purpose:  Updates the object records to establish the relationship
        # Returns:  Boolean
        # Usage:    $rv = _adopt($parent, @children);

        my $obj     = CORE::shift;
        my @orphans = @_;
        my $rv      = 1;
        my $child;

        foreach $child (@orphans) {
            next if $child->isStale;
            if ( !defined $objects[$$child][CEH_PID] ) {

                # Eligible for adoption, record the relationship
                $objects[$$child][CEH_PID] = $$obj;
                CORE::push @{ $objects[$$obj][CEH_CREF] }, $child;

            } else {

                # Already adopted
                if ( $objects[$$child][CEH_PID] != $$obj ) {
                    $@ = "object $$child already adopted by another parent";
                    carp $@;
                    $rv = 0;
                }
            }
        }

        # Merge aliases
        $obj->_mergeAliases;

        return $rv;
    }

    sub _disown {

        # Purpose:  Severs the relationship between the parent and children
        # Returns:  Boolean
        # Usage:    $rv = _disown($parent, @children);

        my $obj     = CORE::shift;
        my @orphans = @_;
        my $rv      = 1;
        my ($child);

        foreach $child (@orphans) {
            if ( defined $objects[$$child][CEH_PID]
                and $objects[$$child][CEH_PID] == $$obj ) {

                # A little alias glue code
                $child->_pruneAliases();

                # Emancipate the child
                $objects[$$child][CEH_PID] = undef;
                $objects[$$obj][CEH_CREF] =
                    [ grep { $_ != $child } @{ $objects[$$obj][CEH_CREF] } ];

                # More alias glue code
                $child->_mergeAliases();
            }
        }

        return $rv;
    }

    sub parent {

        # Purpose:  Returns a reference to the parent object
        # Returns:  Object reference/undef
        # Usage:    $ref = $obj->parent;

        my $obj = CORE::shift;
        my $parent;

        if ( $obj->isStale ) {
            $@ = 'parent method called on stale object';
            carp $@;
        } else {
            $parent = $objects[$$obj][CEH_PID];
            $parent =
                defined $parent
                ? $objects[$parent][CEH_OREF]
                : undef;
        }

        return $parent;
    }

    sub children {

        # Purpose:  Returns a list of child objects
        # Returns:  List of object references
        # Usage:    @children = $obj->children;

        my $obj = CORE::shift;
        my @children;

        if ( $obj->isStale ) {
            $@ = 'children method called on stale object';
            carp $@;
        } else {
            @children = @{ $objects[$$obj][CEH_CREF] };
        }

        return @children;
    }

    sub siblings {

        # Purpose:  Returns a list of siblings
        # Returns:  List of object references
        # Usage:    @sibling = $obj->siblings;

        my $obj = CORE::shift;
        my $parent;

        if ( $obj->isStale ) {
            $@ = 'siblings method called on stale object';
            carp $@;
        } else {
            $parent = $objects[$$obj][CEH_PID];
            $parent = $objects[$parent][CEH_OREF] if defined $parent;
        }

        return defined $parent ? $parent->children : ();
    }

    sub root {

        # Purpose:  Returns the root object of the tree
        # Returns:  Object reference
        # Usage:    $root = $obj->root;

        my $obj = CORE::shift;
        my $pid = $objects[$$obj][CEH_PID];
        my $parent;

        if ( $obj->isStale ) {
            $@ = 'root method called on stale object';
            carp $@;
        } else {

            # Walk up the tree until we find an undefined PID
            $pid = $objects[$$obj][CEH_PID];
            while ( defined $pid ) {
                $parent = $objects[$pid][CEH_OREF];
                $pid    = $objects[$$parent][CEH_PID];
            }

            # The object is the root if no parent was ever found
            $parent = $obj unless defined $parent;
        }

        return $parent;
    }

    sub _getRefById {

        # Purpose:  Returns an object reference by id from the objects array
        # Returns:  Reference
        # Usage:    $obj = _getRefById($index);

        my $id = CORE::shift;

        return defined $id ? $objects[$id][CEH_OREF] : undef;
    }

}

sub adopt {

    # Purpose:  Formally adopts the children
    # Returns:  Boolean
    # Usage:    $rv = $obj->adopt(@children);

    my $obj      = CORE::shift;
    my @children = @_;
    my $root     = $obj->root;
    my $rv;

    if ( $obj->isStale ) {
        $rv = 0;
        $@  = 'adopt method called on stale object';
        carp $@;
    } else {
        if ( grep { $$obj == $$_ } @children ) {
            $rv = 0;
            $@  = 'object attempted to adopt itself';
            carp $@;
        } elsif (
            grep {
                $root eq $_
            } @children
            ) {
            $rv = 0;
            $@  = 'object attempted to adopt the root';
            carp $@;
        } elsif (
            grep {
                !defined or !$_->isa(__PACKAGE__)
            } @children
            ) {
            $rv = 0;
            $@  = 'non-eligible values passed as children for adoption';
            carp $@;
        } else {
            $rv = _adopt( $obj, @children );
        }
    }

    return $rv;
}

sub disown {

    # Purpose:  Formally adopts the children
    # Returns:  Boolean
    # Usage:    $rv = $obj->adopt(@children);

    my $obj      = CORE::shift;
    my @children = @_;
    my $rv;

    if ( $obj->isStale ) {
        $rv = 0;
        $@  = 'disown method called on stale object';
        carp $@;
    } else {
        if ( grep { !defined or !$_->isa(__PACKAGE__) } @children ) {
            $rv = 0;
            $@  = 'non-eligible values passed as children for disowning';
            carp $@;
        } else {
            $rv = _disown( $obj, @children );
        }
    }

    return $rv;
}

sub descendents {

    # Purpose:  Returns all descendents of the object
    # Returns:  List of object references
    # Usage:    @descendents = $obj->descendents;

    my $obj = CORE::shift;
    my ( @children, @descendents, $child );

    if ( $obj->isStale ) {
        $@ = 'descendents method called on stale object';
        carp $@;
    } else {
        @children = $obj->children;
        while (@children) {
            $child = CORE::shift @children;
            CORE::push @descendents, $child;
            CORE::push @children,    $child->children;
        }
    }

    return @descendents;
}

sub _initHierarchy {

    # Purpose:  Initializes the object & class hierarchal data for an object
    # Returns:  Boolean
    # Usage:    $rv = _initHierarchy($obj, $class, @args);

    my $obj     = CORE::shift;
    my $class   = CORE::shift;
    my @args    = @_;
    my @classes = _getClasses($obj);
    my ( $rv, $tclass, %classes );

    # uniq the class list and save it
    %classes = map { $_ => 0 } @classes;

    # Begin initialization from the top down
    foreach $tclass ( reverse @classes ) {
        unless ( $classes{$tclass} ) {

            {
                no strict 'refs';

                # call class _initialize()
                $rv =
                    defined *{"${tclass}::_initialize"}
                    ? &{"${tclass}::_initialize"}( $obj, @args )
                    : 1;

            }

            # Track each class initialization so we only do
            # it once
            $classes{$tclass}++;
        }

        last unless $rv;
    }

    return $rv;
}

sub _destrHierarchy {

    # Purpose:  Destroys hierarchal data for an object
    # Returns:  Boolean
    # Usage:    $rv = _destrHierarchy($obj);

    my $obj     = CORE::shift;
    my @classes = _getClasses($obj);
    my $tclass;

    # Attempt to run all the _deconstruct methods
    {
        no strict 'refs';

        foreach $tclass ( reverse @classes ) {
            &{"${tclass}::_deconstruct"}($obj)
                if defined *{"${tclass}::_deconstruct"};
        }
    }

    return 1;
}

##########################################################
# Alias support
##########################################################

{

    # Array of object aliases
    my @aliases;

    # Array of alias maps
    my @amaps;

    sub _initAlias {

        # Purpose:  Initializes alias data for an object
        # Returns:  Boolean
        # Usage:    $rv = _initAlias($obj, $alias);

        my $obj   = CORE::shift;
        my $alias = CORE::shift;

        # Store the object aliases and initialize a private map
        $aliases[$$obj] = $alias;
        $amaps[$$obj] = defined $alias ? { $alias => $$obj } : {};

        return 1;
    }

    sub _destrAlias {

        # Purpose:  Destroys alias data for an object
        # Returns:  Boolean
        # Usage:    $rv = _destrAlias($obj);

        my $obj   = CORE::shift;
        my $alias = $aliases[$$obj];
        my $root  = $obj->root;

        # Remove aliases from root alias map
        delete $amaps[$$root]{$alias}
            if defined $alias and $amaps[$$root]{$alias} == $$obj;

        # Clean up object data
        $aliases[$$obj] = undef;
        $amaps[$$obj]   = undef;

        return 1;
    }

    sub _mergeAliases {

        # Purpose:  Merges an alias with the family tree alias index
        # Returns:  Boolean
        # Usage:    $rv = _mergeAliases($obj);

        my $obj = CORE::shift;
        my $rv  = 1;
        my ( $child, $alias, $root );

        # The alias index is associated with the root of the tree
        $root = $obj->root;
        foreach $child ( $root->descendents ) {

            # Skip objects without an alias
            next unless defined $aliases[$$child];

            # Get the child's private alias index
            $alias = $aliases[$$child];

            # Update the index if the alias is unclaimed
            if ( CORE::exists $amaps[$$root]{$alias}
                and $amaps[$$root]{$alias} != $$child ) {
                $@ = "alias name collision: $alias";
                carp $@;
                $rv = 0;
            } else {
                $amaps[$$root]{$alias} = $$child;
            }

            # Store the child's prefered alias in its private index,
            # regardless
            $amaps[$$child] = { $alias => $$child };
        }

        return $rv;
    }

    sub _pruneAliases {

        # Purpose:  Removes all aliases from this object and its descendents
        # Returns:  Boolean
        # Usage:    $rv = _prunAliases($obj);

        my $obj = CORE::shift;
        my $rv  = 1;
        my ( $root, $child, $alias );

        $root = $obj->root;
        foreach $child ( $obj, $obj->descendents ) {

            # We never prune aliases from an object's own index for itself
            next if $$child == $$root;

            # Get the alias and remove it from the root's index if the
            # alias if valid and pointing to the child in question
            $alias = $aliases[$$child];
            if ( defined $alias ) {
                delete $amaps[$$root]{$alias}
                    if defined $alias
                        and $amaps[$$root]{$alias} == $$child;
            }
        }

        return $rv;
    }

    sub alias {

        # Purpose:  Assigns an alias to an object
        # Returns:  Boolean
        # Usage:    $rv = $obj->alias($name);

        my $obj   = CORE::shift;
        my $alias = CORE::shift;
        my $rv    = 1;
        my $root;

        if ( $obj->isStale ) {
            $rv = 0;
            $@  = 'alias method called on stale object';
            carp $@;
        } else {
            if ( defined $aliases[$$obj] and length $aliases[$$obj] ) {
                $rv = 0;
                $@  = "object already has an alias: $aliases[$$obj]";
                carp $@;
            } elsif ( !defined $alias or !length $alias ) {
                $rv = 0;
                $@  = 'attempt to assign an invalid alias';
                carp $@;
            } else {

                # Get the root and record the alias in the object's private
                # map
                $root                 = $obj->root;
                $aliases[$$obj]       = $alias;
                $amaps[$$obj]{$alias} = $$obj;

                if ( $$root != $$obj ) {

                    # Update the root index
                    #
                    # Make sure no name collisions
                    if ( CORE::exists $amaps[$$root]{$alias}
                        and $amaps[$$root]{$alias} != $$obj ) {
                        $@ = "alias name collision: $alias";
                        carp $@;
                        $rv = 0;
                    } else {
                        $root = $obj->root;
                        $amaps[$$root]{$alias} = $$obj;
                    }
                }
            }
        }

        return $rv;
    }

    sub getByAlias {

        # Purpose:  Returns an object reference associated with a given name
        # Returns:  Reference
        # Usage:    $oref = $obj->getByAlias($alias);

        my $obj   = CORE::shift;
        my $alias = CORE::shift;
        my ( $root, $rv );

        if ( $obj->isStale ) {
            $rv = 0;
            $@  = 'getByAlias method called on stale object';
            carp $@;
        } elsif ( defined $alias ) {
            $root = $obj->root;
            $rv   = $amaps[$$root]{$alias}
                if CORE::exists $amaps[$$root]{$alias};
            $rv = _getRefById($rv) if defined $rv;
        }

        return $rv;
    }

}

##########################################################
# Property/Method support
##########################################################

{

    # Property storage
    my @properties;

    sub __declProperty {

        # Purpose:  Creates a named property record with associated meta data
        # Returns:  Boolean
        # Usage:    $rv = __declProperty($caller, $obj, $name, $attr);

        my $caller = CORE::shift;
        my $obj    = CORE::shift;
        my $name   = CORE::shift;
        my $attr   = CORE::shift;

        # Prepend package scoping in front of private properties
        $name = "$caller*$name" if $attr & CEH_PRIV;

        # Apply default attributes
        $attr |= CEH_SCALAR
            unless ( $attr ^ CEH_PATTR_TYPE ) > 0;
        $attr |= CEH_PUB
            unless ( $attr ^ CEH_PATTR_SCOPE ) > 0;

        # Save the properties
        ${ $properties[$$obj] }{$name}            = [];
        ${ $properties[$$obj] }{$name}[CEH_PATTR] = $attr;
        ${ $properties[$$obj] }{$name}[CEH_PPKG]  = $caller;
        ${ $properties[$$obj] }{$name}[CEH_PVAL] =
              $attr & CEH_ARRAY ? []
            : $attr & CEH_HASH  ? {}
            :                     undef;

        return 1;
    }

    sub _declProperty {

        # Purpose:  Creates a named property record with associated meta data.
        #           This is the public function available for use by
        #           subclasses
        # Returns:  Boolean
        # Usage:    $rv = _declProperty($obj, $name, $attr);

        my $obj    = CORE::shift;
        my $name   = CORE::shift;
        my $attr   = CORE::shift;
        my $caller = caller;
        my $rv     = !$obj->isStale;

        if ($rv) {
            if ( defined $name and length $name ) {
                $rv = __declProperty( $caller, $obj, $name, $attr );
            } else {
                $@ = '_declProperty function called with an invalid property';
                carp $@;
                $rv = 0;
            }
        } else {
            $@ = '_declProperty function called with a stale object';
            carp $@;
        }

        return $rv;
    }

    sub _gatekeeper {

        # Purpose:  Checks for a valid property name, and checks ACLs for the
        #           caller
        # Returns:  Property name if allowed, undef otherwise
        # Usage:    $name = $obj->gatekeeper($caller, $name);

        my $obj    = CORE::shift;
        my $caller = CORE::shift;
        my $name   = CORE::shift;
        my ( $rv, $class, $cscope, $pscope );

        if ( defined $name and length $name ) {

            # Check scope and adjust for privately scoped properties
            $name = "$caller*$name"
                if CORE::exists $properties[$$obj]{"$caller*$name"};

            if ( CORE::exists $properties[$$obj]{$name} ) {

                # Get the property's class
                $class = $properties[$$obj]{$name}[CEH_PPKG];

                # Get the property's scope
                $pscope =
                    $properties[$$obj]{$name}[CEH_PATTR] & CEH_PATTR_SCOPE;

                # Get the caller's scope
                $cscope =
                      $caller eq $class ? CEH_PRIV
                    : "$caller"->isa($class) ? CEH_RESTR
                    :                          CEH_PUB;

                # Set the values if allowed
                if ( $cscope >= $pscope ) {
                    $rv = $name;
                } else {
                    $@ = 'property access violation';
                    carp $@;
                }

            } else {
                $@ = 'method called with an nonexistent property';
                carp $@;
            }
        } else {
            $@ = 'method called with an invalid property name';
            carp $@;
        }

        return $rv;
    }

    sub _setProperty {

        # Purpose:  Sets the named property to the passed values
        # Returns:  Boolean
        # Usage:    $rv = $obj->_setProperty($name, @values);

        my $obj  = CORE::shift;
        my $name = CORE::shift;
        my @val  = @_;
        my ( $rv, $ptype, $pundef, $pref );

        # Get some meta data
        $ptype  = ${ $properties[$$obj] }{$name}[CEH_PATTR] & CEH_PATTR_TYPE;
        $pundef = ${ $properties[$$obj] }{$name}[CEH_PATTR] & CEH_NO_UNDEF;

        if ( $ptype != CEH_ARRAY and $ptype != CEH_HASH ) {
            $pref = ref $val[0];

            # Check for undef restrictions
            $rv = 1 if !$pundef or defined $val[0];

            if ($rv) {

                # Check types for correctness
                $rv =
                      ( !defined $val[0] ) ? 1
                    : $ptype == CEH_SCALAR ? ( $pref eq '' )
                    : $ptype == CEH_CODE   ? ( $pref eq 'CODE' )
                    : $ptype == CEH_GLOB   ? ( $pref eq 'GLOB' )
                    : $ptype == CEH_REF    ? ( length $pref )
                    :                        0;

                $@ = "data type mismatch for $name";
                carp $@ unless $rv;
            }

        } else {

            # No validation for array/hash types
            $rv = 1;
        }

        # Assign the value(s)
        if ($rv) {
            if ( $ptype == CEH_ARRAY ) {
                ${ $properties[$$obj] }{$name}[CEH_PVAL] = [@val];
            } elsif ( $ptype == CEH_HASH ) {
                ${ $properties[$$obj] }{$name}[CEH_PVAL] = {@val};
            } else {
                ${ $properties[$$obj] }{$name}[CEH_PVAL] = $val[0];
            }
        }

        return $rv;
    }

    sub set {

        # Purpose:  Sets the named properties to the passed value(s)
        # Returns:  Boolean
        # Usage:    $rv = $obj->set($name, @values);

        my $obj    = CORE::shift;
        my $name   = CORE::shift;
        my @val    = @_;
        my $caller = caller;
        my $rv     = !$obj->isStale;

        if ($rv) {
            $name = $obj->_gatekeeper( $caller, $name );
            if ( defined $name ) {
                $rv = $obj->_setProperty( $name, @val );
            } else {
                $rv = 0;
            }
        } else {
            $@ = 'set method called on a stale object';
            carp $@;
        }

        return $rv;
    }

    sub _getProperty {

        # Purpose:  Gets the named property's value(s)
        # Returns:  Scalar, Array, Hash, etc.
        # Usage:    @rv = $obj->getProperty($name);

        my $obj  = CORE::shift;
        my $name = CORE::shift;
        my ( @rv, $ptype );

        # Get some meta data
        $ptype = $properties[$$obj]{$name}[CEH_PATTR] & CEH_PATTR_TYPE;

        # Retrieve the content
        @rv =
              $ptype == CEH_HASH  ? %{ $properties[$$obj]{$name}[CEH_PVAL] }
            : $ptype == CEH_ARRAY ? @{ $properties[$$obj]{$name}[CEH_PVAL] }
            :                       ( $properties[$$obj]{$name}[CEH_PVAL] );

        return
              $ptype == CEH_HASH  ? @rv
            : $ptype == CEH_ARRAY ? @rv
            :                       $rv[0];
    }

    sub get {

        # Purpose:  Gets the named property's value(s)
        # Returns:  Scalar, Array, Hash, etc.
        # Usage:    @rv = $obj->get($name);

        my $obj    = CORE::shift;
        my $name   = CORE::shift;
        my $caller = caller;
        my @rv;

        if ( !$obj->isStale ) {
            $name = $obj->_gatekeeper( $caller, $name );
            if ( defined $name ) {
                @rv = $obj->_getProperty($name);
            }
        } else {
            $@ = 'set method called on a stale object';
            carp $@;
        }

        return wantarray ? @rv : $rv[0];
    }

    sub push {

        # Purpose:  Performs a push operation on an array property
        # Returns:  RV of CORE::push or undef
        # Usage:    $rv = $obj->push($name, @values);

        my $obj    = CORE::shift;
        my $name   = CORE::shift;
        my @val    = @_;
        my $caller = caller;
        my $rv     = !$obj->isStale;

        if ($rv) {
            $rv = undef;
            $name = $obj->_gatekeeper( $caller, $name );
            if ( defined $name ) {
                if ( ref $properties[$$obj]{$name}[CEH_PVAL] eq 'ARRAY' ) {
                    $rv = CORE::push @{ $properties[$$obj]{$name}[CEH_PVAL] },
                        @val;
                } else {
                    $@ = 'push attempted on a non-array property';
                    carp $@;
                }
            }
        } else {
            $@ = 'push method called on a stale object';
            carp $@;
        }

        return $rv;
    }

    sub pop {

        # Purpose:  Performs a pop operation on an array property
        # Returns:  RV of CORE::pop or undef
        # Usage:    $rv = $obj->pop($name);

        my $obj    = CORE::shift;
        my $name   = CORE::shift;
        my $caller = caller;
        my $rv     = !$obj->isStale;

        if ($rv) {
            $rv = undef;
            $name = $obj->_gatekeeper( $caller, $name );
            if ( defined $name ) {
                if ( ref $properties[$$obj]{$name}[CEH_PVAL] eq 'ARRAY' ) {
                    $rv = CORE::pop @{ $properties[$$obj]{$name}[CEH_PVAL] };
                } else {
                    $@ = 'pop attempted on a non-array property';
                    carp $@;
                }
            }
        } else {
            $@ = 'pop method called on a stale object';
            carp $@;
        }

        return $rv;
    }

    sub unshift {

        # Purpose:  Performs an unshift operation on an array property
        # Returns:  RV of CORE::unshift or undef
        # Usage:    $rv = $obj->unshift($name, @values);

        my $obj    = CORE::shift;
        my $name   = CORE::shift;
        my @val    = @_;
        my $caller = caller;
        my $rv     = !$obj->isStale;

        if ($rv) {
            $rv = undef;
            $name = $obj->_gatekeeper( $caller, $name );
            if ( defined $name ) {
                if ( ref $properties[$$obj]{$name}[CEH_PVAL] eq 'ARRAY' ) {
                    $rv =
                        CORE::unshift @{ $properties[$$obj]{$name}[CEH_PVAL]
                        },
                        @val;
                } else {
                    $@ = 'unshift attempted on a non-array property';
                    carp $@;
                }
            }
        } else {
            $@ = 'unshift method called on a stale object';
            carp $@;
        }

        return $rv;
    }

    sub shift {

        # Purpose:  Performs a shift operation on an array property
        # Returns:  RV of CORE::shift or undef
        # Usage:    $rv = $obj->shift($name);

        my $obj    = CORE::shift;
        my $name   = CORE::shift;
        my $caller = caller;
        my $rv     = !$obj->isStale;

        if ($rv) {
            $rv = undef;
            $name = $obj->_gatekeeper( $caller, $name );
            if ( defined $name ) {
                if ( ref $properties[$$obj]{$name}[CEH_PVAL] eq 'ARRAY' ) {
                    $rv =
                        CORE::shift @{ $properties[$$obj]{$name}[CEH_PVAL] };
                } else {
                    $@ = 'shift attempted on a non-array property';
                    carp $@;
                }
            }
        } else {
            $@ = 'shift method called on a stale object';
            carp $@;
        }

        return $rv;
    }

    sub exists {

        # Purpose:  Performs an exists operation on a hash property
        # Returns:  RV of CORE::exists or undef
        # Usage:    $rv = $obj->exists($name, $key);

        my $obj    = CORE::shift;
        my $name   = CORE::shift;
        my $key    = CORE::shift;
        my $caller = caller;
        my $rv     = !$obj->isStale;

        if ($rv) {
            $rv = undef;
            $name = $obj->_gatekeeper( $caller, $name );
            if ( defined $name ) {
                if ( ref $properties[$$obj]{$name}[CEH_PVAL] eq 'HASH' ) {
                    $rv =
                        CORE::exists $properties[$$obj]{$name}[CEH_PVAL]
                        {$key};
                } else {
                    $@ = 'exists attempted on a non-hash property';
                    carp $@;
                }
            }
        } else {
            $@ = 'exists method called on a stale object';
            carp $@;
        }

        return $rv;
    }

    sub keys {

        # Purpose:  Performs a keys operation on a hash property
        # Returns:  RV of CORE::keys or empty array
        # Usage:    $rv = $obj->keys($name);

        my $obj    = CORE::shift;
        my $name   = CORE::shift;
        my $caller = caller;
        my @rv;

        if ( !$obj->isStale ) {
            $name = $obj->_gatekeeper( $caller, $name );
            if ( defined $name ) {
                if ( ref $properties[$$obj]{$name}[CEH_PVAL] eq 'HASH' ) {
                    @rv = CORE::keys %{ $properties[$$obj]{$name}[CEH_PVAL] };
                } else {
                    $@ = 'keys attempted on a non-hash property';
                    carp $@;
                }
            }
        } else {
            $@ = 'keys method called on a stale object';
            carp $@;
        }

        return @rv;
    }

    sub merge {

        # Purpose:  Merges the specified ordinal or associated records into
        #           the named property
        # Returns:  Boolean
        # Usage:    $rv = $obj->merge($name, 'foo' => 'bar');
        # Usage:    $rv = $obj->merge($name, 1 => 'bar');

        my $obj     = CORE::shift;
        my $name    = CORE::shift;
        my %updates = @_;
        my $rv      = !$obj->isStale;
        my $caller  = caller;
        my ( $k, $v );

        if ($rv) {
            $name = $obj->_gatekeeper( $caller, $name );
            if ( defined $name ) {
                if ( ref $properties[$$obj]{$name}[CEH_PVAL] eq 'ARRAY' ) {
                    while ( ( $k, $v ) = each %updates ) {
                        $properties[$$obj]{$name}[CEH_PVAL][$k] = $v;
                    }
                } elsif ( ref $properties[$$obj]{$name}[CEH_PVAL] eq 'HASH' )
                {
                    while ( ( $k, $v ) = each %updates ) {
                        $properties[$$obj]{$name}[CEH_PVAL]{$k} = $v;
                    }
                } else {
                    $@ = 'merge attempted on a non-hash/array property';
                    carp $@;
                }
            }
        } else {
            $@ = 'merge method called on a stale object';
            carp $@;
        }

        return $rv;
    }

    sub subset {

        # Purpose:  Returns the associated or ordinal values from the named
        #           property
        # Returns:  Array of values
        # Usage:    @values = $obj->subset($name, qw(foo bar));
        # Usage:    @values = $obj->subset($name, 1, 7);

        my $obj    = CORE::shift;
        my $name   = CORE::shift;
        my @keys   = @_;
        my $caller = caller;
        my ( @rv, $k, $l );

        if ( !$obj->isStale ) {
            $name = $obj->_gatekeeper( $caller, $name );
            if ( defined $name ) {
                if ( ref $properties[$$obj]{$name}[CEH_PVAL] eq 'ARRAY' ) {
                    $l = $#{ $properties[$$obj]{$name}[CEH_PVAL] };
                    foreach $k (@keys) {
                        CORE::push @rv, (
                              $k <= $l
                            ? $properties[$$obj]{$name}[CEH_PVAL][$k]
                            : undef
                            );
                    }
                } elsif ( ref $properties[$$obj]{$name}[CEH_PVAL] eq 'HASH' )
                {
                    foreach $k (@keys) {
                        CORE::push @rv, (
                            CORE::exists $properties[$$obj]{$name}[CEH_PVAL]
                                {$k}
                            ? $properties[$$obj]{$name}[CEH_PVAL]{$k}
                            : undef
                            );
                    }
                } else {
                    $@ = 'subset attempted on a non-hash/array property';
                    carp $@;
                }
            }
        } else {
            $@ = 'subset method called on a stale object';
            carp $@;
        }

        return @rv;
    }

    sub remove {

        # Purpose:  Removes the ordinal or associated values from the named
        #           property
        # Returns:  Boolean
        # Usage:    $rv = $obj->remove($name, qw(foo bar));
        # Usage:    $rv = $obj->remove($name, 5, 8);

        my $obj    = CORE::shift;
        my $name   = CORE::shift;
        my @keys   = @_;
        my $caller = caller;
        my $rv     = !$obj->isStale;
        my ( $k, $l );

        if ($rv) {
            $name = $obj->_gatekeeper( $caller, $name );
            if ( defined $name ) {
                if ( ref $properties[$$obj]{$name}[CEH_PVAL] eq 'ARRAY' ) {
                    $l = $#{ $properties[$$obj]{$name}[CEH_PVAL] };
                    foreach $k ( sort { $b <=> $a } @keys ) {
                        splice @{ $properties[$$obj]{$name}[CEH_PVAL] }, $k, 1
                            unless $k > $l;
                    }
                } elsif ( ref $properties[$$obj]{$name}[CEH_PVAL] eq 'HASH' )
                {
                    foreach $k (@keys) {
                        delete $properties[$$obj]{$name}[CEH_PVAL]{$k};
                    }
                } else {
                    $@ = 'remove attempted on a non-hash/array property';
                    carp $@;
                }
            }
        } else {
            $@ = 'remove method called on a stale object';
            carp $@;
        }

        return $rv;
    }

    sub empty {

        # Purpose:  Empties the named array or hash property
        # Returns:  Boolean
        # Usage:    $rv = $obj->empty($name);

        my $obj    = CORE::shift;
        my $name   = CORE::shift;
        my $caller = caller;
        my $rv     = !$obj->isStale;

        if ($rv) {
            $name = $obj->_gatekeeper( $caller, $name );
            if ( defined $name ) {
                if ( ref $properties[$$obj]{$name}[CEH_PVAL] eq 'ARRAY' ) {
                    @{ $properties[$$obj]{$name}[CEH_PVAL] } = ();
                } elsif ( ref $properties[$$obj]{$name}[CEH_PVAL] eq 'HASH' )
                {
                    %{ $properties[$$obj]{$name}[CEH_PVAL] } = ();
                } else {
                    $@ = 'empty attempted on a non-hash/array property';
                    carp $@;
                }
            }
        } else {
            $@ = 'empty method called on a stale object';
            carp $@;
        }

        return $rv;
    }

    sub properties {

        # Purpose:  Returns a list of property names visible to the caller
        # Returns:  Array of scalars
        # Usage:    @names = $obj->properties;

        my $obj    = CORE::shift;
        my $caller = caller;
        my @pnames = CORE::keys %{ $properties[$$obj] };
        my @rv;

        # Populate with all the public properties
        @rv =
            grep { $properties[$$obj]{$_}[CEH_PATTR] & CEH_PUB } @pnames;

        # Add restricted properties if the caller is a subclass
        if ( $caller eq ref $obj
            or "$caller"->isa($obj) ) {
            CORE::push @rv,
                grep { $properties[$$obj]{$_}[CEH_PATTR] & CEH_RESTR }
                @pnames;
        }

        # Add private properties if the caller is the same class
        if ( $caller eq ref $obj ) {
            foreach ( grep /^\Q$caller*\E/s, @pnames ) {
                CORE::push @rv, $_;
                $rv[$#rv] =~ s/^\Q$caller*\E//s;
            }
        }

        return @rv;
    }

    sub _initProperties {

        # Purpose:  Initializes the property data for the object
        # Returns:  Boolean
        # Usage:    $rv = _initProperties($obj);

        my $obj     = CORE::shift;
        my @classes = _getClasses($obj);
        my $rv      = 1;
        my ( $class, @_properties, $prop, $pattr, $pscope, $pname );

        # Initialize storage
        $properties[$$obj] = {};

        # Load properties from top of class hierarchy down
        foreach $class (@classes) {

            # Get the contents of the class array
            {
                no strict 'refs';

                @_properties =
                    defined *{"${class}::_properties"}
                    ? @{ *{"${class}::_properties"}{ARRAY} }
                    : ();
            }

            # Process the list
            foreach $prop (@_properties) {
                next unless defined $prop;

                unless (
                    __declProperty(
                        $class, $obj, @$prop[ CEH_PNAME, CEH_PATTR ] )
                    ) {
                    $rv = 0;
                    last;
                }

                # Set the default values
                if ( $rv and defined $$prop[CEH_PVAL] ) {

                    # Get the attribute type, scope, and internal prop name
                    $pattr  = $$prop[CEH_PATTR] & CEH_PATTR_TYPE;
                    $pscope = $$prop[CEH_PATTR] & CEH_PATTR_SCOPE;
                    $pname =
                        $pscope == CEH_PRIV
                        ? "${class}::$$prop[CEH_PNAME]"
                        : $$prop[CEH_PNAME];

                    # Store the default values
                    $rv = $obj->_setProperty( $pname,
                          $pattr == CEH_ARRAY ? @{ $$prop[CEH_PVAL] }
                        : $pattr == CEH_HASH  ? %{ $$prop[CEH_PVAL] }
                        :                       $$prop[CEH_PVAL] );
                }

                last unless $rv;
            }

        }

        return $rv;
    }

    sub _destrProperties {

        # Purpose:  Destroys the object's property data
        # Returns:  Boolean
        # Usage:    $rv = _destrProperties($obj);

        my $obj = CORE::shift;

        $properties[$$obj] = undef;

        return 1;
    }

}

{
    my %classes;    # Class => 1
    my %methods;    # Class::Method => 1

    sub __declMethod {

        # Purpose:  Registers a list of methods as scoped
        # Returns:  Boolean
        # Usage:    $rv = __declMethod($class, $attr, $methods);

        my $pkg    = CORE::shift;
        my $attr   = CORE::shift;
        my $method = CORE::shift;
        my $rv     = 1;
        my ( $code, $mfqn );

        if ( defined $attr and defined $method and length $method ) {

            # Quiet some warnings
            no warnings qw(redefine prototype);
            no strict 'refs';

            # Get the fully qualified method name and associated code
            # block
            $mfqn = "${pkg}::${method}";
            $code = *{$mfqn}{CODE};

            # Quick check to see if we've done this already -- if so
            # we skip to the next
            return 1 if CORE::exists $methods{$mfqn};

            if ( defined $code ) {

                # Repackage
                if ( $attr == CEH_PRIV ) {

                    # Private methods
                    *{$mfqn} = sub {
                        my $caller = caller;
                        goto &{$code} if $caller eq $pkg;
                        $@ = 'Attempted to call private method '
                            . "$method from $caller";
                        carp $@;
                        return 0;
                    };

                } elsif ( $attr == CEH_RESTR ) {

                    # Restricted methods
                    *{$mfqn} = sub {
                        my $caller = caller;
                        goto &{$code} if "$caller"->isa($pkg);
                        $@ = 'Attempted to call restricted method '
                            . "$method from $caller";
                        carp $@;
                        return 0;
                    };
                } elsif ( $attr == CEH_PUB ) {

                    # Do nothing

                } else {
                    $@ = 'invalid method declaration';
                    carp $@;
                    $rv = 0;
                }

                # Record our handling of this method
                $methods{$mfqn} = 1 if $rv;

            }

        } else {
            $@ = 'invalid method declaration';
            carp $@;
            $rv = 0;
        }

        return $rv;
    }

    sub _declMethod {

        # Purpose:  Wrapper for __declMethod, this is the public interface
        # Returns:  RV of __declMethod
        # Usage:    $rv = _declMethod($attr, @propNames);

        my $attr   = CORE::shift;
        my $method = CORE::shift;
        my $caller = caller;
        my $rv     = 1;

        if ( defined $method and length $method ) {
            $rv = __declMethod( $caller, $attr, $method );
        } else {
            $@ = '_declMethod function called with an invalid method';
            carp $@;
            $rv = 0;
        }

        return $rv;
    }

    sub _initMethods {

        # Purpose:  Loads methods from @_methods
        # Returns:  Boolean
        # Usage:    $rv = _loadMethods();

        my $obj     = CORE::shift;
        my @classes = _getClasses($obj);
        my $rv      = 1;
        my ( $class, @_methods, $method );

        # Load methods from the top of the class hierarchy down
        foreach $class (@classes) {

            # Skip if the class has already been processed
            next if CORE::exists $classes{$class};

            # Get the contents of the class array
            {
                no strict 'refs';

                @_methods = @{ *{"${class}::_methods"}{ARRAY} }
                    if defined *{"${class}::_methods"};
            }

            # Process the list
            foreach $method (@_methods) {
                next unless defined $method;
                unless (
                    __declMethod( $class, @$method[ CEH_PATTR, CEH_PPKG ] ) )
                {
                    $rv = 0;
                    last;
                }
            }

            # Mark the class as processed
            $classes{$class} = 1;
        }

        return $rv;
    }

}

##########################################################
# Class Constructors/Destructors
##########################################################

sub new {

    # Purpose:  Class constructor for all (sub)classes
    # Returns:  Reference
    # Usage:    $obj = new SUBCLASS;
    my $class = CORE::shift;
    my @args  = @_;
    my $obj   = bless \do { my $anon_scalar }, $class;
    my $rv;

    # Get the next available ID
    $rv = _getID($obj);

    # Initialize alias support
    $rv = _initAlias($obj) if $rv;

    # Initialize property scope support
    $rv = _initProperties($obj) if $rv;

    # Initialize method scope support
    $rv = _initMethods($obj) if $rv;

    # Initialize the hierarchal code support
    $rv = _initHierarchy( $obj, $class, @args ) if $rv;

    return $rv ? $obj : undef;
}

sub conceive {

    # Purpose:  Same as new() but with hierarchal relationships pre-installed
    # Returns:  Reference
    # Usage:    SubClass->conceive($parent, @args);

    my $class = CORE::shift;
    my $pobj  = CORE::shift;
    my @args  = @_;
    my $obj   = bless \do { my $anon_scalar }, $class;
    my $rv    = 1;

    # Get the next available ID
    $rv = _getID($obj) if $rv;

    # Adopt the object before we do anything else
    $rv = $pobj->_adopt($obj) if $rv;

    # Initialize property scope support
    $rv = _initProperties($obj) if $rv;

    # Initialize method scope support
    $rv = _initMethods($obj) if $rv;

    # Initialize the hierarchal code support
    $rv = _initHierarchy( $obj, $class, @args ) if $rv;

    # Disown the object if we've failed initialization
    $pobj->_disown($obj) unless $rv;

    return $rv ? $obj : undef;
}

sub DESTROY {

    # Purpose:  Garbage collection
    # Returns:  Boolean
    # Usage:    $obj->DESTROY();

    my $obj = CORE::shift;
    my ( $class, @classes );

    # Test to see if this is a stale reference
    unless ( !defined $$obj or $obj->isStale ) {

        # Destroy from the top of the tree down
        foreach ( $obj->children ) { $_->DESTROY if defined }

        # Execute hierarchal destructors
        _destrHierarchy($obj);

        # Destroy aliases
        _destrAlias($obj);

        # Destroy properties
        _destrProperties($obj);

        # Recover the ID
        _delID($obj);
    }

    return 1;
}

END {
    foreach ( _dumpObjects() ) { $_->DESTROY if defined }
}

1;

__END__