view release on metacpan or  search on metacpan

lib/Class/EHierarchy.pm  view on Meta::CPAN

# Class::EHierarchy -- Base class for hierarchally ordered objects
#
# (c) 2017, Arthur Corliss <corliss@digitalmages.com>
#
# $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;