File Coverage

blib/lib/Class/EHierarchy.pm

Criterion	Covered	Total	%
statement	621	656	94.6
branch	150	198	75.7
condition	29	45	64.4
subroutine	78	79	98.7
pod	23	23	100.0
total	901	1001	90.0

# Class::EHierarchy -- Base class for hierarchally ordered objects
#
# (c) 2009, Arthur Corliss
#
# $Id: EHierarchy.pm,v 0.93 2013/07/07 00:17:27 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: 0.93 $ =~ /(\d+(?:\.(\d+))+)/sm );

# Ordinal indexes for the @objects element records
use constant CEH_OREF  => 0;
use constant CEH_PREF  => 1;
use constant CEH_PKG   => 2;
use constant CEH_SUPER => 3;
use constant CEH_CREF  => 4;
use constant CEH_CNAME => 5;
use constant CEH_ALIAS => 6;

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

# Property attribute masks
use constant CEH_ATTR_SCOPE => 7;
use constant CEH_ATTR_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 _declProp
    _declMethod );
%EXPORT_TAGS = ( all => [@EXPORT_OK] );

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

{

    # Object list
    #   @objects = ( [ ref:parent_obj, [ ref:child_obj, ... ] ] );
    my @objects;

    # Available IDs
    my @available;

    # Properties
    #   @properties = ( { propName => [ int:attr, value ] } );
    my @properties;

    # Methods
    #   %methods = ( '__PACKAGE__::method' => 1 );
    my %methods;

    # Object aliases
    #   %aliases = ( alias => ref:obj );

    sub _dumpDiags () {

        # Purpose:  Dumps some diagnostic information from class structures
        # Returns:  Boolean
        # Usage:    _dumpDiags();

        my ( $obj, @rec, $i );

        warn "\nCEH Objects: @{[ scalar @objects ]}\n";

        $i = 0;
        foreach $obj (@objects) {
            if ( defined $obj and @rec = @$obj ) {
                foreach (@rec) {
                    $_ = 'undef' unless defined $_;
                }
                warn "CEH Obj #$i: @rec\n";
            } else {
                warn "CEH Obj #$i: unused\n";
            }
            $i++;
        }

        return 1;
    }

    # INTERNAL FUNCTIONS

    sub _ident () {

        # Purpose:  Returns next available ID
        # Returns:  Integer
        # Usage:    $id = _ident();

        return scalar @available ? CORE::shift @available : $#objects + 1;
    }

    sub _regObj (@) {

        # Purpose:  Registers the object for tracking
        # Returns:  Boolean
        # Usage:    $rv = _regObj($oref);

        my $obj = CORE::shift;

        # Initialize internal tracking
        $objects[$$obj]            = [];
        $objects[$$obj][CEH_PREF]  = undef;
        $objects[$$obj][CEH_PKG]   = ref $obj;
        $objects[$$obj][CEH_SUPER] = [];
        $objects[$$obj][CEH_CREF]  = [];
        $objects[$$obj][CEH_CNAME] = __PACKAGE__ . '0';
        $objects[$$obj][CEH_ALIAS] = {};
        $properties[$$obj]         = {};

        return 1;
    }

    sub _deregObj (@) {

        # Purpose:  Removes the object from tracking
        # Returns:  Boolean
        # Usage:    $rv = _deregObj($oref);

        my $obj = CORE::shift;

        # Remove structures and make ID available
        $objects[$$obj] = $properties[$$obj] = undef;
        CORE::push @available, $$obj;

        return 1;
    }

    sub _mergeAliases ($$) {

        # Purpose:  Merges child aliases into parent aliases
        # Returns:  Boolean
        # Usage:    _mergeAliases($parent, $child);

        my $parent = CORE::shift;
        my $child  = CORE::shift;
        my ( @aliases, $alias, $class, $i );

        # Preserve aliases if possible
        @aliases = CORE::keys %{ $objects[$$child][CEH_ALIAS] };
        foreach $alias (@aliases) {
            if ( exists $objects[$$parent][CEH_ALIAS]{$alias} ) {

                # generate new alias
                $i     = 0;
                $class = ref $child;
                while ( exists $objects[$$parent][CEH_ALIAS]{"$class$i"} ) {
                    $i++;
                }
                $objects[$$parent][CEH_ALIAS]{"$class$i"} =
                    $objects[$$child][CEH_ALIAS]{$alias};
                weaken $objects[$$parent][CEH_ALIAS]{"$class$i"};
                $objects[$$child][CEH_CNAME] = "$class$i";

            } else {

                # transfer alias intact
                $objects[$$parent][CEH_ALIAS]{$alias} =
                    $objects[$$child][CEH_ALIAS]{$alias};
                weaken $objects[$$parent][CEH_ALIAS]{$alias};
            }
        }

        # Sync alias hashes
        $objects[$$child][CEH_ALIAS] = $objects[$$parent][CEH_ALIAS];

        return 1;
    }

    sub _spliceAliases ($$) {

        # Purpose:  Splits the aliase tree
        # Returns:  Boolean
        # Usage:    _spliceAliases($parent, $child);

        my $parent   = CORE::shift;
        my $child    = CORE::shift;
        my @children = ( $child, $child->descendants );
        my ( $pref, $cref, $cname );

        $pref = $objects[$$parent][CEH_ALIAS];
        $cref = $objects[$$child][CEH_ALIAS] = {};

        foreach $child (@children) {
            $cname = $objects[$$child][CEH_CNAME];
            delete $$pref{$cname};
            $$cref{$cname} = $child;
            weaken $$cref{$cname};
        }

        return 1;
    }

    sub _assocObj ($@) {

        # Purpose:  Associates objects as children of the parent
        # Returns:  Boolean
        # Usage:    $rv = _assocObj( $parent, $child1, $child2 );

        my $parent  = CORE::shift;
        my @orphans = @_;
        my $rv      = 1;
        my ( $orphan, @descendants, $n, $i, $irv, $class );

        foreach $orphan (@orphans) {
            if ( !defined $orphan ) {

                # Filter out undefined references
                $@  = 'undefined value passed as an object reference';
                $rv = 0;

            } elsif ( !$orphan->isa('Class::EHierarchy') ) {

                # You can only adopt objects derived from this class
                $@ = 'child object isn\'t derived from '
                    . "Class::EHierarchy: $orphan";
                $rv = 0;

            } elsif ( $$parent == $$orphan ) {

                # Really?  You want to adopt yourself?  I'm sensing a chicken
                # and the egg problem...
                $@  = "attempted to adopt one's self: $parent";
                $rv = 0;

            } elsif ( defined $objects[$$orphan][CEH_PREF] ) {

                # We don't allow kidnapping...
                $@  = "attempted kidnapping of a parented child: $orphan";
                $rv = 0;

            } else {

                # Objects are currently orphans...
                #
                # Now, make sure no (grand)?children of the orphan will create
                # a circular reference
                @descendants = $orphan->descendants;
                $irv         = 1;

                # Stop if our proposed parent is in this list
                if ( grep { $$_ == $$parent } @descendants ) {
                    $@ = "circular reference detected between $parent "
                        . "& $orphan";
                    $irv = $rv = 0;
                }

                if ($irv) {

                    # No circular references, so now let's update the records
                    $objects[$$orphan][CEH_PREF] = $parent;
                    weaken( $objects[$$orphan][CEH_PREF] );
                    CORE::push @{ $objects[$$parent][CEH_CREF] }, $orphan;

                    # Merge aliasas
                    _mergeAliases( $parent, $orphan );
                }
            }
        }

        return $rv;
    }

    sub _disassocObj ($@) {

        # Purpose:  Removes the child/parent relationship
        # Returns:  Boolean
        # Usage:    $rv = _disassocObj($parent, $child1, $child2):

        my $parent   = CORE::shift;
        my @children = CORE::shift;
        my $child;

        foreach $child (@children) {

            # Make sure the child actually belongs to the parent
            if ( $objects[$$child][CEH_PREF] == $parent ) {

                # Remove the child objref from the parent's list
                @{ $objects[$$parent][CEH_CREF] } =
                    grep { $_ != $child } @{ $objects[$$parent][CEH_CREF] };

                # Update the child's record
                $objects[$$child][CEH_PREF] = undef;

                # Split aliases
                _spliceAliases( $parent, $child );
            }
        }

        return 1;
    }

    sub _cscope ($$) {

        # Purpose:  Determines the caller's scope in relation to the object
        #           being acted upon
        # Returns:  CEH_PRIV, CEH_RESTR, or CEH_PUB
        # Usage:    $cscope = _cscope($caller, $obj);
        # Usage:    $cscope = _cscope($caller, $pkg);

        my $caller = CORE::shift;
        my $pkg    = CORE::shift;

        # Set $pkg to either the resolved package name (if it's an object
        # reference) or leave it as a plain string package name
        $pkg = $objects[$$pkg][CEH_PKG] unless ref $pkg eq '';

        return
              $caller eq $pkg ? CEH_PRIV
            : "$caller"->isa($pkg) ? CEH_RESTR
            :                        CEH_PUB;
    }

    sub _chkAccess ($$$) {

        # Purpose:  Checks to see if the caller is allowed access to the
        #           requested property.  If the caller is granted access it
        #           will return the name of the property (which may be
        #           adjusted for privately scoped properties), otherwise it
        #           croaks.
        # Returns:  name of property
        # Usage:    $prop = _chkAccess($caller, $prop);

        my $self   = CORE::shift;
        my $caller = CORE::shift;
        my $prop   = CORE::shift;
        my ( $opkg, $cscope, $pscope );

        # Modify the property name for to check for private properties
        $prop = "${caller}::$prop"
            if defined $prop and !exists ${ $properties[$$self] }{$prop};

        if ( defined $prop and CORE::exists ${ $properties[$$self] }{$prop} )
        {

            # Get the object package
            $opkg = $objects[$$self][CEH_PKG];

            # Property CORE::exists, check the caller & property scopes
            $cscope =
                _cscope( $caller, $properties[$$self]{$prop}[CEH_PPKG] );
            $pscope =
                ${ $properties[$$self] }{$prop}[CEH_ATTR] & CEH_ATTR_SCOPE;

            unless ( $cscope >= $pscope ) {

                # Caller is not authorized
                $pscope =
                      $pscope == CEH_PRIV  ? 'private'
                    : $pscope == CEH_RESTR ? 'restricted'
                    :                        'public';
                croak "Attempted access of $pscope property $prop by $caller";
            }

        } else {

            # Undefined or nonexistent property
            $prop = '\'undef\'' unless defined $prop;
            croak "Attempted access of nonexistent property $prop";
        }

        return $prop;
    }

    sub __declProp {

        # Purpose:  Registers list of properties as known
        # Returns:  Boolean
        # Usage:    $rv = __declProp($caller, $obj, $attr, @propNames);

        my $caller = CORE::shift;
        my $obj    = CORE::shift;
        my $attr   = CORE::shift;
        my @names  = splice @_;
        my $rv     = 0;
        my $prop;

        if ( defined $attr ) {
            $rv = 1;
            @names = grep {defined} @names;

            # Preprocess private properties to avoid naming conflicts
            if ( $attr & CEH_PRIV ) {

                # Prepend the caller's package to the property names to avoid
                # naming conflicts with subclasses
                foreach (@names) { $_ = "${caller}::$_" }
            }

            foreach $prop (@names) {
                croak "property '$prop' already defined"
                    if CORE::exists ${ $properties[$$obj] }{$prop};

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

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

        return $rv;
    }

    sub _declProp {

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

        my $caller = caller;
        my @args   = splice @_;

        return __declProp( $caller, @args );
    }

    sub _loadProps($$) {

        # Purpose:  Loads properties from @_properties
        # Returns:  Boolean
        # Usage:    $rv = _loadProps();

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

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

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

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

            unless (
                __declProp( $class, $obj, @$prop[ CEH_ATTR, CEH_PPKG ] ) ) {
                $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_ATTR] & CEH_ATTR_TYPE;
                $pscope = $$prop[CEH_ATTR] & CEH_ATTR_SCOPE;
                $pname =
                    $pscope == CEH_PRIV
                    ? "${class}::$$prop[CEH_PPKG]"
                    : $$prop[CEH_PPKG];

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

        return $rv;
    }

    sub _setProp ($$@) {

        # Purpose:  Sets the designated property to the passed value(s).
        #           Does some rough validation according to attributes
        # Returns:  Boolean
        # Usage:    $rv = _setProp($obj, 'foo', qw(one two three));

        my $obj  = CORE::shift;
        my $prop = CORE::shift;
        my @val  = splice @_;
        my $rv   = 0;
        my ( $pattr, $pundef, $pval, $pref );

        # NOTE: since we're screening for valid properties and access
        # rights in the property method we won't be doing any validation
        # here
        $pattr  = ${ $properties[$$obj] }{$prop}[CEH_ATTR] & CEH_ATTR_TYPE;
        $pundef = ${ $properties[$$obj] }{$prop}[CEH_ATTR] & CEH_NO_UNDEF;

        # Do some quick validation of references (not necessary for
        # hash/array types)
        if ( $pattr != CEH_ARRAY and $pattr != CEH_HASH ) {
            $pref = ref $val[0];

            if ( not defined $val[0] ) {

                # Only allow undef values if the properties allow
                # undef values
                $rv = 1 if not $pundef;

            } else {

                # Check defined values
                if ( $pattr == CEH_SCALAR ) {
                    $rv = 1 if $pref eq '';
                } elsif ( $pattr == CEH_CODE ) {
                    $rv = 1 if $pref eq 'CODE';
                } elsif ( $pattr == CEH_GLOB ) {
                    $rv = 1 if $pref eq 'GLOB';
                } elsif ( $pattr == CEH_REF ) {
                    $rv = 1 if $pref ne '';
                } else {
                    croak 'something\'s wrong with property attribute '
                        . "type for $prop";
                }
            }
        } else {
            $rv = 1;
        }

        # In this context only hashes and arrays need special handling
        if ($rv) {
            if ( $pattr == CEH_ARRAY ) {
                ${ $properties[$$obj] }{$prop}[CEH_PVAL] = [@val];
            } elsif ( $pattr == CEH_HASH ) {
                ${ $properties[$$obj] }{$prop}[CEH_PVAL] = {@val};
            } else {
                ${ $properties[$$obj] }{$prop}[CEH_PVAL] = $val[0];
            }
        }

        return $rv;
    }

    sub _getProp ($$) {

        # Purpose:  Returns the requested property value, dereferencing
        #           appropriately, depending on property type
        # Returns:  n/a
        # Usage:    $val = _getProp($obj, 'foo');
        # Usage:    @val = _getProp($obj, 'bar');
        # Usage:    %val = _getProp($obj, 'foo');

        my ( $obj, $prop ) = @_;
        my ( $pattr, $pval );

        # NOTE: since we're screening for valid properties and access
        # rights in the property method we won't be doing any validation
        # here
        $pattr = ${ $properties[$$obj] }{$prop}[CEH_ATTR] & CEH_ATTR_TYPE;
        $pval  = ${ $properties[$$obj] }{$prop}[CEH_PVAL];

        # In this context only hashes and arrays need special handling
        return
              $pattr == CEH_ARRAY ? @$pval
            : $pattr == CEH_HASH  ? %$pval
            :                       $pval;
    }

    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 @names = splice @_;
        my ( $code, $method, $mfqn );

        if ( defined $attr ) {

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

            foreach $method (@names) {

                # 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
                next if $methods{$mfqn};

                if ( defined $code ) {

                    # Repackage
                    if ( $attr == CEH_PRIV ) {

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

                    } elsif ( $attr == CEH_RESTR ) {

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

                } else {
                    croak "Method $method declared but not defined";
                }

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

        return 1;
    }

    sub _declMethod {

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

        my $caller = caller;
        my @args   = splice @_;

        return __declMethod( $caller, @args );
    }

    sub _loadMethods {

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

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

        # 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_ATTR, CEH_PPKG ] ) )
            {
                $rv = 0;
                last;
            }
        }

        return $rv;
    }

    # PUBLISHED METHODS

    sub new ($;@) {

        # Purpose:  Object constructor
        # Returns:  Object reference
        # Usage:    $obj = Class->new(@args);

        my $class = CORE::shift;
        my @args  = @_;
        my $self  = bless \do { my $anon_scalar }, $class;
        my ( $rv, @classes, $tclass, $nclass, $l, $n, $isaref );
        my ( %super, $alias );

        # Set the id and register
        $$self = _ident();
        _regObj($self);

        # Assemble a list of superclasses derived from this class that
        # will need initialization
        no strict 'refs';
        $isaref = *{"${class}::ISA"}{ARRAY};
        $isaref = [] unless defined $isaref;
        foreach $tclass (@$isaref) {
            CORE::push @classes, $tclass
                if $tclass ne __PACKAGE__
                    and "$tclass"->isa(__PACKAGE__);
        }
        $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;
        }

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

        # Add our current package to the list
        CORE::unshift @classes, $class;

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

                # Save the class list for the desconstructor
                unshift @{ $objects[$$self][CEH_SUPER] }, $tclass;

                # First autoload @_properties & @_methods
                $rv = _loadProps( $tclass, $self ) && _loadMethods($tclass);
                unless ($rv) {
                    _deregObj($self);
                    $self = undef;
                    last;
                }

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

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

            unless ($rv) {
                _deregObj($self);
                $self = undef;
                last;
            }
        }

        # Generate alias
        if ($self) {
            $alias = $objects[$$self][CEH_CNAME];
            $objects[$$self][CEH_ALIAS]{$alias} = $self;
            weaken $objects[$$self][CEH_ALIAS]{$alias};
        }

        return $self;
    }

    sub parent ($) {

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

        my $self = CORE::shift;

        return $objects[$$self][CEH_PREF];
    }

    sub root ($) {

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

        my $self = CORE::shift;
        my ( $obj, $parent );

        $obj = $self;
        while ( defined( $parent = $obj->parent ) ) {
            $obj = $parent;
        }

        return $obj;
    }

    sub children ($) {

        # Purpose:  Returns a list of object references to this object's
        #           children
        # Returns:  Array
        # Usage:    @crefs = $obj->children;

        my $self = CORE::shift;

        return @{ $objects[$$self][CEH_CREF] };
    }

    sub descendants ($) {

        # Purpose:  Returns a list of object references to all
        #           (grand)children of this object
        # Returns:  Array
        # Usage:    @descendants = $obj->descendants;

        my $self     = CORE::shift;
        my @children = @{ $objects[$$self][CEH_CREF] };
        my @rv       = @children;

        foreach (@children) {
            push @rv, $_->descendants;
        }

        return @rv;
    }

    sub siblings ($) {

        # Purpose:  Returns a list of object references to this object's
        #           siblings
        # Returns:  Array
        # Usage:    @crefs = $obj->siblings;

        my $self = CORE::shift;
        my $pref = $objects[$$self][CEH_PREF];
        my @rv;

        @rv = grep { $_ != $self } @{ $objects[$$pref][CEH_CREF] }
            if defined $pref;

        return @rv;
    }

    sub relative ($$) {

        # Purpose:  Returns an object reference for an exact match on
        #           an alias
        # Returns:  Object reference
        # Usage:    $oref = $obj->relative('foo');

        my $self  = CORE::shift;
        my $alias = CORE::shift;
        my $rv;

        if ( defined $alias ) {
            $rv = $objects[$$self][CEH_ALIAS]{$alias}
                if exists $objects[$$self][CEH_ALIAS]{$alias};
        }

        return $rv;
    }

    sub relatives ($$) {

        # Purpose:  Returns an object reference for an regex match on
        #           an alias
        # Returns:  Array
        # Usage:    $oref = $obj->relatives('foo');

        my $self  = CORE::shift;
        my $alias = CORE::shift;
        my ( @aliases, @rv );

        if ( defined $alias ) {
            @aliases = grep m#^\Q$alias\E#sm,
                keys %{ $objects[$$self][CEH_ALIAS] };
            foreach $alias (@aliases) {
                push @rv, $objects[$$self][CEH_ALIAS]{$alias};
            }
        }

        return @rv;
    }

    sub alias ($;$) {

        # Purpose:  Get/Set object alias
        # Returns:  String/Boolean
        # Usage:    $rv = $obj->alias;

        my $self  = CORE::shift;
        my $alias = CORE::shift;
        my $rv;

        if ( defined $alias ) {

            # Set alias
            if ( exists $objects[$$self][CEH_ALIAS]{$alias} ) {

                # Alias already in use -- fail
                $rv = 0;

            } else {

                # Move to new alias
                delete $objects[$$self][CEH_ALIAS]
                    { $objects[$$self][CEH_CNAME] };
                $objects[$$self][CEH_ALIAS]{$alias} = $self;
                $objects[$$self][CEH_CNAME] = $alias;
                weaken $objects[$$self][CEH_ALIAS]{$alias};
                $rv = 1;
            }

        } else {

            # Get alias
            $rv = $objects[$$self][CEH_CNAME];
        }

        return $rv;
    }

    sub adopt ($@) {

        # Purpose:  Adopts the passed object references as children
        # Returns:  Boolean
        # Usage:    $rv = $obj->adopt($cobj1, $cobj2);

        my $self     = CORE::shift;
        my @children = @_;
        my $rv       = 0;

        $rv = _assocObj( $self, @children ) if @children;

        return $rv;
    }

    sub disown ($@) {

        # Purpose:  Disowns the passed object references as children
        # Returns:  Boolean
        # Usage:    $rv = $obj->disown($cobj1, $cobj2);

        my $self     = CORE::shift;
        my @children = @_;

        return _disassocObj( $self, @children );
    }

    sub property ($$;$) {

        # Purpose:  Gets/sets the requested property
        # Returns:  Boolean on value sets, value on gets
        # Usage:    @numbers = $obj->property('numbers');
        # Usage:    $rv = $obj->property('numbers',
        #                 qw(555-1212 999-1111));

        my $self   = CORE::shift;
        my $prop   = CORE::shift;
        my @values = @_;
        my $caller = caller;
        my ($rv);

        # Check for access rights
        $prop = _chkAccess( $self, $caller, $prop );

        # Caller is authorized, determine the mode
        if (@values) {

            # set mode
            return _setProp( $self, $prop, @values );

        } else {

            # get mode
            return _getProp( $self, $prop );
        }

        return 1;
    }

    sub propertyNames ($) {

        # Purpose:  Returns a list of all property names
        # Returns:  Array
        # Usage:    @names = $obj->propertyNames;

        my $self   = CORE::shift;
        my $caller = caller;
        my ( $opkg, $cscope, $pscope, @rv );

        # Get the object package
        $opkg = $objects[$$self][CEH_PKG];

        # Property CORE::exists, check the caller & property scopes
        $cscope = _cscope( $caller, $opkg );

        # Iterate over all properties get the ones accessible to the caller
        foreach ( keys %{ $properties[$$self] } ) {
            $pscope = ${ $properties[$$self] }{$_}[CEH_ATTR] & CEH_ATTR_SCOPE;
            next
                if $pscope == CEH_PRIV
                    and ${ $properties[$$self] }{$_}[CEH_PPKG] ne $opkg;
            CORE::push @rv, $_ if $cscope >= $pscope;
        }

        return @rv;
    }

    # Array-specific methods

    sub push ($$@) {

        # Purpose:  pushes values onto the requested array property,
        # Returns:  The return value of the CORE::push
        # Usage:    $rv = $obj->push($prop, @values);

        my $self   = CORE::shift;
        my $prop   = CORE::shift;
        my @values = splice @_;
        my $caller = caller;
        my $pattr;

        # Check for access rights
        $prop = _chkAccess( $self, $caller, $prop );

        # Make sure it's an array
        $pattr = ${ $properties[$$self] }{$prop}[CEH_ATTR] & CEH_ATTR_TYPE;
        croak "Can't push values onto a non-array like $prop"
            unless $pattr == CEH_ARRAY;

        # push the values
        return CORE::push @{ ${ $properties[$$self] }{$prop}[CEH_PVAL] },
            @values;
    }

    sub pop ($$) {

        # Purpose:  pops values off of the requested array property,
        # Returns:  The return value of CORE::pop
        # Usage:    $rv = $obj->pop($prop);

        my $self   = CORE::shift;
        my $prop   = CORE::shift;
        my $caller = caller;
        my $pattr;

        # Check for access rights
        $prop = _chkAccess( $self, $caller, $prop );

        # Make sure it's an array
        $pattr = ${ $properties[$$self] }{$prop}[CEH_ATTR] & CEH_ATTR_TYPE;
        croak "Can't pop values off of a non-array like $prop"
            unless $pattr == CEH_ARRAY;

        # pop the values
        return CORE::pop @{ ${ $properties[$$self] }{$prop}[CEH_PVAL] };
    }

    sub unshift ($$@) {

        # Purpose:  unshifts values onto the requested array property,
        # Returns:  The return value of the CORE::unshift
        # Usage:    $rv = $obj->unshift($prop, @values);

        my $self   = CORE::shift;
        my $prop   = CORE::shift;
        my @values = splice @_;
        my $caller = caller;
        my $pattr;

        # Check for access rights
        $prop = _chkAccess( $self, $caller, $prop );

        # Make sure it's an array
        $pattr = ${ $properties[$$self] }{$prop}[CEH_ATTR] & CEH_ATTR_TYPE;
        croak "Can't unshift values onto a non-array like $prop"
            unless $pattr == CEH_ARRAY;

        # unshift the values
        return CORE::unshift @{ ${ $properties[$$self] }{$prop}[CEH_PVAL] },
            @values;
    }

    sub shift ($$) {

        # Purpose:  shifts values off of the requested array property,
        # Returns:  The return value of CORE::shift
        # Usage:    $rv = $obj->shift($prop);

        my $self   = CORE::shift;
        my $prop   = CORE::shift;
        my $caller = caller;
        my $pattr;

        # Check for access rights
        $prop = _chkAccess( $self, $caller, $prop );

        # Make sure it's an array
        $pattr = ${ $properties[$$self] }{$prop}[CEH_ATTR] & CEH_ATTR_TYPE;
        croak "Can't shift values off of a non-array like $prop"
            unless $pattr == CEH_ARRAY;

        # shift the values
        return CORE::shift @{ ${ $properties[$$self] }{$prop}[CEH_PVAL] };
    }

    # Hash-specific methods

    sub exists ($$$) {

        # Purpose:  checks the existance of a key in the property hash
        # Returns:  The return value of CORE::exists
        # Usage:    $rv = $obj->exists($prop, $key);

        my $self   = CORE::shift;
        my $prop   = CORE::shift;
        my $key    = CORE::shift;
        my $caller = caller;
        my $pattr;

        # Check for access rights
        $prop = _chkAccess( $self, $caller, $prop );

        # Make sure it's a hash
        $pattr = ${ $properties[$$self] }{$prop}[CEH_ATTR] & CEH_ATTR_TYPE;
        croak "Can't check for a key in a non-hash like $prop"
            unless $pattr == CEH_HASH;

        # Check for the key
        return CORE::exists ${ ${ $properties[$$self] }{$prop}[CEH_PVAL] }
            {$key};
    }

    sub keys ($$) {

        # Purpose:  Retrieves a list of keys of the given hash property
        # Returns:  The return value of CORE::keys
        # Usage:    $rv = $obj->keys($prop, $key);

        my $self   = CORE::shift;
        my $prop   = CORE::shift;
        my $caller = caller;
        my $pattr;

        # Check for access rights
        $prop = _chkAccess( $self, $caller, $prop );

        # Make sure it's a hash
        $pattr = ${ $properties[$$self] }{$prop}[CEH_ATTR] & CEH_ATTR_TYPE;
        croak "Can't check for keys in a non-hash like $prop"
            unless $pattr == CEH_HASH;

        # Get the keys
        return CORE::keys %{ ${ $properties[$$self] }{$prop}[CEH_PVAL] };
    }

    # Unified hash/array methods

    sub store ($$@) {

        # Purpose:  Adds elements to either an array or hash
        # Returns:  Boolean
        # Usage:    $rv = $obj->add($prop, foo => bar);
        # Usage:    $rv = $obj->add($prop, 4 => foo, 5 => bar);

        my $self   = CORE::shift;
        my $prop   = CORE::shift;
        my @pairs  = splice @_;
        my $caller = caller;
        my ( $pattr, $i, $v );

        # Check for access rights
        $prop = _chkAccess( $self, $caller, $prop );

        # Make sure it's an array or hash
        $pattr = ${ $properties[$$self] }{$prop}[CEH_ATTR] & CEH_ATTR_TYPE;
        croak "Can't retrieve values for non-hash/arrays like $prop"
            unless $pattr == CEH_HASH
                or $pattr == CEH_ARRAY;

        if ( $pattr == CEH_HASH ) {

            # Add the key-pairs
            %{ ${ $properties[$$self] }{$prop}[CEH_PVAL] } =
                ( %{ ${ $properties[$$self] }{$prop}[CEH_PVAL] }, @pairs );

        } else {

            # Set the values to the specified indices
            while (@pairs) {
                $i = CORE::shift @pairs;
                $v = CORE::shift @pairs;
                ${ $properties[$$self] }{$prop}[CEH_PVAL][$i] = $v;
            }
        }

        return 1;
    }

    sub retrieve ($$@) {

        # Purpose:  Retrieves all the requested array or hash property
        #           elements
        # Returns:  List of values
        # Usage:    @values = $obj->retrieve($array, 3 .. 5 );
        # Usage:    @values = $obj->retrieve($hash, qw(foo bar) );

        my $self     = CORE::shift;
        my $prop     = CORE::shift;
        my @elements = splice @_;
        my $caller   = caller;
        my ( $pattr, $rv );

        # Check for access rights
        $prop = _chkAccess( $self, $caller, $prop );

        # Make sure it's an array or hash
        $pattr = ${ $properties[$$self] }{$prop}[CEH_ATTR] & CEH_ATTR_TYPE;
        croak "Can't retrieve values for non-hash/arrays like $prop"
            unless $pattr == CEH_HASH
                or $pattr == CEH_ARRAY;

        if ( $pattr == CEH_ARRAY ) {
            if ( @elements == 1 and !wantarray ) {
                return ${ ${ $properties[$$self] }{$prop}[CEH_PVAL] }
                    [ $elements[0] ];
            } else {
                return @{ ${ $properties[$$self] }{$prop}[CEH_PVAL] }
                    [@elements];
            }
        } else {
            if ( @elements == 1 and !wantarray ) {
                return ${ ${ $properties[$$self] }{$prop}[CEH_PVAL] }
                    { $elements[0] };
            } else {
                return @{ ${ $properties[$$self] }{$prop}[CEH_PVAL] }
                    {@elements};
            }
        }

        return 1;
    }

    sub remove ($$@) {

        # Purpose:  Removes the specified elements from the hash or array
        # Returns:  Boolean
        # Usage:    $obj->remove($prop, @keys);

        my $self     = CORE::shift;
        my $prop     = CORE::shift;
        my @elements = splice @_;
        my $caller   = caller;
        my ( $pattr, $i, @narray );

        # Check for access rights
        $prop = _chkAccess( $self, $caller, $prop );

        # Make sure it's an array or hash
        $pattr = ${ $properties[$$self] }{$prop}[CEH_ATTR] & CEH_ATTR_TYPE;
        croak "Can't remove values for non-hash/arrays like $prop"
            unless $pattr == CEH_HASH
                or $pattr == CEH_ARRAY;

        if ( $pattr == CEH_ARRAY ) {
            @narray = @{ ${ $properties[$$self] }{$prop}[CEH_PVAL] };
            ${ $properties[$$self] }{$prop}[CEH_PVAL] = [];
            foreach ( $i = 0; $i <= $#narray; $i++ ) {
                next if grep { $_ == $i } @elements;
                CORE::push @{ ${ $properties[$$self] }{$prop}[CEH_PVAL] },
                    $narray[$i];
            }
        } else {
            delete @{ ${ $properties[$$self] }{$prop}[CEH_PVAL] }{@elements};
        }

        return 1;
    }

    sub purge ($$) {

        # Purpose:  Empties the specified hash or array property
        # Returns:  Boolean
        # Usage:    $obj->remove($prop);

        my $self     = CORE::shift;
        my $prop     = CORE::shift;
        my @elements = splice @_;
        my $caller   = caller;
        my ( $pattr, $i, @narray );

        # Check for access rights
        $prop = _chkAccess( $self, $caller, $prop );

        # Make sure it's an array or hash
        $pattr = ${ $properties[$$self] }{$prop}[CEH_ATTR] & CEH_ATTR_TYPE;
        croak "Can't remove values for non-hash/arrays like $prop"
            unless $pattr == CEH_HASH
                or $pattr == CEH_ARRAY;

        ${ $properties[$$self] }{$prop}[CEH_PVAL] =
            $pattr == CEH_ARRAY ? [] : {};

        return 1;
    }

    sub DESTROY ($) {

        # Purpose:  Walks the child heirarchy and releases all those
        #           children before finally releasing this object
        # Returns:  Boolean
        # Usage:    $obj->DESTROY;

        my $self = CORE::shift;
        my ( @descendants, $child, $parent, $class );

        if ( defined $objects[$$self] ) {

            # Working backwards we'll disown each child and release it
            @descendants = $self->descendants;
            foreach $child ( reverse @descendants ) {
                $parent = $child->parent;
                $parent = $self unless defined $parent;
                $parent->disown($child);
                $child = undef;
            }

            # Third, execute the _deconstruct from the bottom up
            no strict 'refs';
            foreach $class ( @{ $objects[$$self][CEH_SUPER] } ) {
                &{"${class}::_deconstruct"}($self)
                    if defined *{"${class}::_deconstruct"};
            }

            # Fourth, deregister object
            _deregObj($self);
        }

        return 1;
    }
}

1;

__END__