[libclass-ehierarchy-perl] 01/09: New upstream version 2.00
Lucas Kanashiro
kanashiro at moszumanska.debian.org
Tue Jun 20 23:19:16 UTC 2017
This is an automated email from the git hooks/post-receive script.
kanashiro pushed a commit to branch master
in repository libclass-ehierarchy-perl.
commit 55d3352da743efd5b4e356c3625ac11cf857d8a7
Author: Lucas Kanashiro <kanashiro at debian.org>
Date: Tue Jun 20 17:35:16 2017 -0300
New upstream version 2.00
---
CHANGELOG | 5 +
MANIFEST | 17 +-
META.json | 41 +
META.yml | 35 +-
Makefile.PL | 33 +-
README | 16 +-
lib/Class/EHierarchy.pm | 2867 ++++++++++++++++++++++++---------------------
t/{01_ini.t => 01_init.t} | 3 +-
t/02_object_hierarchy.t | 72 ++
t/02_relationships.t | 105 --
t/03_class_hierarchy.t | 99 ++
t/03_properties.t | 371 ------
t/04_alias.t | 98 ++
t/04_array_methods.t | 128 --
t/05_hash_methods.t | 99 --
t/05_properties.t | 221 ++++
t/06_methods.t | 44 +-
t/07_loadProps.t | 364 ------
t/07_type_methods.t | 99 ++
t/08_loadMethods.t | 170 ---
t/09_aliases.t | 72 --
21 files changed, 2240 insertions(+), 2719 deletions(-)
diff --git a/CHANGELOG b/CHANGELOG
index d81588f..f403c68 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,5 +1,10 @@
CHANGELOG
+v2.00 (2017/01/23)
+==================
+--Complete rewrite
+--New API
+
v0.93 (2013/07/06)
==================
--Modified DESTROY method to call all superclass _deconstruct methods
diff --git a/MANIFEST b/MANIFEST
index 1d7ef72..45e6a25 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -5,15 +5,14 @@ INSTALL
MANIFEST
LICENSE
lib/Class/EHierarchy.pm
-t/01_ini.t
-t/02_relationships.t
-t/03_properties.t
-t/04_array_methods.t
-t/05_hash_methods.t
+t/01_init.t
+t/02_object_hierarchy.t
+t/03_class_hierarchy.t
+t/04_alias.t
+t/05_properties.t
t/06_methods.t
-t/07_loadProps.t
-t/08_loadMethods.t
-t/09_aliases.t
+t/07_type_methods.t
t/98_pod_coverage.t
t/99_pod.t
-META.yml Module meta-data (added by MakeMaker)
+META.yml Module YAML meta-data (added by MakeMaker)
+META.json Module JSON meta-data (added by MakeMaker)
diff --git a/META.json b/META.json
new file mode 100644
index 0000000..7c21a87
--- /dev/null
+++ b/META.json
@@ -0,0 +1,41 @@
+{
+ "abstract" : "Base class for hierarchally ordered objects",
+ "author" : [
+ "Arthur Corliss <corliss at digitalmages.com>"
+ ],
+ "dynamic_config" : 1,
+ "generated_by" : "ExtUtils::MakeMaker version 6.86, CPAN::Meta::Converter version 2.120351",
+ "license" : [
+ "perl_5"
+ ],
+ "meta-spec" : {
+ "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
+ "version" : "2"
+ },
+ "name" : "Class-EHierarchy",
+ "no_index" : {
+ "directory" : [
+ "t",
+ "inc"
+ ]
+ },
+ "prereqs" : {
+ "build" : {
+ "requires" : {
+ "ExtUtils::MakeMaker" : "0"
+ }
+ },
+ "configure" : {
+ "requires" : {
+ "ExtUtils::MakeMaker" : "0"
+ }
+ },
+ "runtime" : {
+ "requires" : {
+ "perl" : "5.008003"
+ }
+ }
+ },
+ "release_status" : "stable",
+ "version" : "2.00"
+}
diff --git a/META.yml b/META.yml
index 8032e1b..2e61aad 100644
--- a/META.yml
+++ b/META.yml
@@ -1,19 +1,22 @@
---- #YAML:1.0
-name: Class-EHierarchy
-version: 0.93
-abstract: Base class for hierarchally ordered objects
+---
+abstract: 'Base class for hierarchally ordered objects'
author:
- - Arthur Corliss <corliss at digitalmages.com>
-license: perl
-distribution_type: module
+ - 'Arthur Corliss <corliss at digitalmages.com>'
+build_requires:
+ ExtUtils::MakeMaker: 0
configure_requires:
- ExtUtils::MakeMaker: 0
-requires: {}
-no_index:
- directory:
- - t
- - inc
-generated_by: ExtUtils::MakeMaker version 6.46
+ ExtUtils::MakeMaker: 0
+dynamic_config: 1
+generated_by: 'ExtUtils::MakeMaker version 6.86, CPAN::Meta::Converter version 2.120351'
+license: perl
meta-spec:
- url: http://module-build.sourceforge.net/META-spec-v1.4.html
- version: 1.4
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
+name: Class-EHierarchy
+no_index:
+ directory:
+ - t
+ - inc
+requires:
+ perl: 5.008003
+version: 2.00
diff --git a/Makefile.PL b/Makefile.PL
index e5ffc28..c39e615 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -2,19 +2,24 @@ use ExtUtils::MakeMaker;
use 5.008003;
WriteMakefile(
- NAME => 'Class::EHierarchy',
- AUTHOR => 'Arthur Corliss <corliss at digitalmages.com>',
- ABSTRACT => 'Base class for hierarchally ordered objects',
- VERSION_FROM => 'lib/Class/EHierarchy.pm',
- PREREQ_PM => {},
- ($ExtUtils::MakeMaker::VERSION ge '6.30_00'? (
- LICENSE => 'perl' ) : () ),
- dist => {
- COMPRESS => 'gzip',
- SUFFIX => '.gz',
- CI => 'cvs ci',
- RCS_LABEL => 'cvs tag -c -F $(NAME_SYM)-$(VERSION_SYM)',
- },
-);
+ NAME => 'Class::EHierarchy',
+ AUTHOR => 'Arthur Corliss <corliss at digitalmages.com>',
+ ABSTRACT => 'Base class for hierarchally ordered objects',
+ VERSION_FROM => 'lib/Class/EHierarchy.pm',
+ PREREQ_PM => {}, (
+ $ExtUtils::MakeMaker::VERSION ge '6.30_00' ? ( LICENSE => 'perl' )
+ : ()
+ ), (
+ $ExtUtils::MakeMaker::VERSION ge '6.48'
+ ? ( MIN_PERL_VERSION => 5.008003 )
+ : ()
+ ),
+ dist => {
+ COMPRESS => 'gzip',
+ SUFFIX => '.gz',
+ CI => 'cvs ci',
+ RCS_LABEL => 'cvs tag -c -F $(NAME_SYM)-$(VERSION_SYM)',
+ },
+ );
exit 0;
diff --git a/README b/README
index 0e8204e..253cbf7 100644
--- a/README
+++ b/README
@@ -1,10 +1,16 @@
Class::EHierarchy
=================
-Like all CPAN modules, just enter the following commands:
+NOTICE: One might wonder how we've jumped from 0.x releases to 2.x. I've
+decided to skip the 1.x releases to make it (hopefully) more obvious that
+the API has changed and is not compatible with the 0.x series. My fear was
+that the average devmight see 0.x to 1.x and assume that I was simply
+declaring the API stable. While 2.x is a stable API it is not compatible
+with 0.x.
- $ perl Makefile.PL
- $ make
- $ make test
- $ make install
+--
+
+Class::EHierarchy is intended to provide a base class for objects that
+require both object and class hierarchal features. For more information on
+what that means, please see the POD.
diff --git a/lib/Class/EHierarchy.pm b/lib/Class/EHierarchy.pm
index 2d5bf49..b68a38e 100644
--- a/lib/Class/EHierarchy.pm
+++ b/lib/Class/EHierarchy.pm
@@ -1,8 +1,8 @@
# Class::EHierarchy -- Base class for hierarchally ordered objects
#
-# (c) 2009, Arthur Corliss <corliss at digitalmages.com>
+# (c) 2017, Arthur Corliss <corliss at digitalmages.com>
#
-# $Id: EHierarchy.pm,v 0.93 2013/07/07 00:17:27 acorliss Exp $
+# $Id: lib/Class/EHierarchy.pm, 2.00 2017/01/09 08:47:12 acorliss Exp $
#
# This software is licensed under the same terms as Perl, itself.
# Please see http://dev.perl.org/licenses/ for more information.
@@ -26,25 +26,24 @@ use base qw(Exporter);
use Carp;
use Scalar::Util qw(weaken);
-($VERSION) = ( q$Revision: 0.93 $ =~ /(\d+(?:\.(\d+))+)/sm );
+($VERSION) = ( q$Revision: 2.00 $ =~ /(\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;
+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_ATTR => 0;
-use constant CEH_PPKG => 1;
-use constant CEH_PVAL => 2;
+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_ATTR_SCOPE => 7;
-use constant CEH_ATTR_TYPE => 504;
+use constant CEH_PATTR_SCOPE => 7;
+use constant CEH_PATTR_TYPE => 504;
# Property attribute scopes
use constant CEH_PUB => 1;
@@ -64,7 +63,7 @@ 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
+ CEH_HASH CEH_CODE CEH_REF CEH_GLOB CEH_NO_UNDEF _declProperty
_declMethod );
%EXPORT_TAGS = ( all => [@EXPORT_OK] );
@@ -74,1311 +73,1644 @@ use constant CEH_NO_UNDEF => 512;
#
#####################################################################
+##########################################################
+# Hierarchal code support
+##########################################################
+
{
- # Object list
- # @objects = ( [ ref:parent_obj, [ ref:child_obj, ... ] ] );
+ # Array of object references and metadata
my @objects;
- # Available IDs
- my @available;
+ # Array of recycled IDs availabe for use
+ my @recoveredIDs;
- # Properties
- # @properties = ( { propName => [ int:attr, value ] } );
- my @properties;
+ sub _dumpObjects {
+
+ # Purpose: Provides a list of objects
+ # Returns: List of refs
+ # Usage: @objects = _dumpObjects();
- # Methods
- # %methods = ( '__PACKAGE__::method' => 1 );
- my %methods;
+ return map { $$_[CEH_OREF] } grep {defined} @objects;
+ }
- # Object aliases
- # %aliases = ( alias => ref:obj );
+ sub _getID {
- sub _dumpDiags () {
+ # Purpose: Generates and assigns a unique ID to the passed
+ # object, and initializes the internal records
+ # Returns: Integer
+ # Usage: $id = _genID();
- # Purpose: Dumps some diagnostic information from class structures
- # Returns: Boolean
- # Usage: _dumpDiags();
+ 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 ( $obj, @rec, $i );
+ my ( $isaref, $tclass, $nclass, @classes, $n, $l );
+ my $class = ref $obj;
- warn "\nCEH Objects: @{[ scalar @objects ]}\n";
+ # 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__);
+ }
- $i = 0;
- foreach $obj (@objects) {
- if ( defined $obj and @rec = @$obj ) {
- foreach (@rec) {
- $_ = 'undef' unless defined $_;
+ # 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__);
+ }
}
- warn "CEH Obj #$i: @rec\n";
- } else {
- warn "CEH Obj #$i: unused\n";
+ $n = scalar @classes - $l + 1;
+ $l = scalar @classes;
}
- $i++;
+
+ # Add our current class
+ CORE::push @classes, $class;
+
+ # Save the list
+ foreach (@classes) { _addClass( $obj, $_ ) }
}
- return 1;
+ return $id;
}
- # INTERNAL FUNCTIONS
+ sub _delID {
- sub _ident () {
+ # Purpose: Recovers the ID for re-use while deleting the
+ # old data structures
+ # Returns: Boolean
+ # Usage: _recoverID($id);
- # Purpose: Returns next available ID
- # Returns: Integer
- # Usage: $id = _ident();
+ my $obj = CORE::shift;
+ my $pid = $objects[$$obj][CEH_PID];
+ my @children = @{ $objects[$$obj][CEH_CREF] };
- return scalar @available ? CORE::shift @available : $#objects + 1;
+ # 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 _regObj (@) {
+ sub isStale {
- # Purpose: Registers the object for tracking
+ # Purpose: Checks to see if the object reference is
+ # stale
# Returns: Boolean
- # Usage: $rv = _regObj($oref);
+ # Usage: $rv = $obj->isStale;
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;
+ return not( defined $obj
+ and defined $objects[$$obj]
+ and defined $objects[$$obj][CEH_OREF]
+ and $obj eq $objects[$$obj][CEH_OREF] );
}
- sub _deregObj (@) {
+ sub _addClass {
- # Purpose: Removes the object from tracking
+ # Purpose: Records a super class for the object
# Returns: Boolean
- # Usage: $rv = _deregObj($oref);
+ # Usage: $rv = _addClass($obj, $class);
- my $obj = CORE::shift;
+ my $obj = CORE::shift;
+ my $class = CORE::shift;
- # Remove structures and make ID available
- $objects[$$obj] = $properties[$$obj] = undef;
- CORE::push @available, $$obj;
+ CORE::push @{ $objects[$$obj][CEH_CLASSES] }, $class
+ if defined $class
+ and not grep /^$class$/s, @{ $objects[$$obj][CEH_CLASSES] };
return 1;
}
- sub _mergeAliases ($$) {
+ 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: Merges child aliases into parent aliases
+ # Purpose: Updates the object records to establish the relationship
# 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";
+ # 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 {
- # transfer alias intact
- $objects[$$parent][CEH_ALIAS]{$alias} =
- $objects[$$child][CEH_ALIAS]{$alias};
- weaken $objects[$$parent][CEH_ALIAS]{$alias};
+ # Already adopted
+ if ( $objects[$$child][CEH_PID] != $$obj ) {
+ $@ = "object $$child already adopted by another parent";
+ carp $@;
+ $rv = 0;
+ }
}
}
- # Sync alias hashes
- $objects[$$child][CEH_ALIAS] = $objects[$$parent][CEH_ALIAS];
+ # Merge aliases
+ $obj->_mergeAliases;
- return 1;
+ return $rv;
}
- sub _spliceAliases ($$) {
+ sub _disown {
- # Purpose: Splits the aliase tree
+ # Purpose: Severs the relationship between the parent and children
# Returns: Boolean
- # Usage: _spliceAliases($parent, $child);
+ # 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 ) {
- my $parent = CORE::shift;
- my $child = CORE::shift;
- my @children = ( $child, $child->descendants );
- my ( $pref, $cref, $cname );
+ # A little alias glue code
+ $child->_pruneAliases();
- $pref = $objects[$$parent][CEH_ALIAS];
- $cref = $objects[$$child][CEH_ALIAS] = {};
+ # Emancipate the child
+ $objects[$$child][CEH_PID] = undef;
+ $objects[$$obj][CEH_CREF] =
+ [ grep { $_ != $child } @{ $objects[$$obj][CEH_CREF] } ];
- foreach $child (@children) {
- $cname = $objects[$$child][CEH_CNAME];
- delete $$pref{$cname};
- $$cref{$cname} = $child;
- weaken $$cref{$cname};
+ # More alias glue code
+ $child->_mergeAliases();
+ }
}
- return 1;
+ return $rv;
}
- sub _assocObj ($@) {
+ sub parent {
- # Purpose: Associates objects as children of the parent
- # Returns: Boolean
- # Usage: $rv = _assocObj( $parent, $child1, $child2 );
+ # Purpose: Returns a reference to the parent object
+ # Returns: Object reference/undef
+ # Usage: $ref = $obj->parent;
- my $parent = CORE::shift;
- my @orphans = @_;
- my $rv = 1;
- my ( $orphan, @descendants, $n, $i, $irv, $class );
+ my $obj = CORE::shift;
+ my $parent;
- foreach $orphan (@orphans) {
- if ( !defined $orphan ) {
+ if ( $obj->isStale ) {
+ $@ = 'parent method called on stale object';
+ carp $@;
+ } else {
+ $parent = $objects[$$obj][CEH_PID];
+ $parent =
+ defined $parent
+ ? $objects[$parent][CEH_OREF]
+ : undef;
+ }
- # Filter out undefined references
- $@ = 'undefined value passed as an object reference';
- $rv = 0;
+ return $parent;
+ }
- } elsif ( !$orphan->isa('Class::EHierarchy') ) {
+ sub children {
- # You can only adopt objects derived from this class
- $@ = 'child object isn\'t derived from '
- . "Class::EHierarchy: $orphan";
- $rv = 0;
+ # Purpose: Returns a list of child objects
+ # Returns: List of object references
+ # Usage: @children = $obj->children;
- } elsif ( $$parent == $$orphan ) {
+ my $obj = CORE::shift;
+ my @children;
- # Really? You want to adopt yourself? I'm sensing a chicken
- # and the egg problem...
- $@ = "attempted to adopt one's self: $parent";
- $rv = 0;
+ if ( $obj->isStale ) {
+ $@ = 'children method called on stale object';
+ carp $@;
+ } else {
+ @children = @{ $objects[$$obj][CEH_CREF] };
+ }
- } elsif ( defined $objects[$$orphan][CEH_PREF] ) {
+ return @children;
+ }
- # We don't allow kidnapping...
- $@ = "attempted kidnapping of a parented child: $orphan";
- $rv = 0;
+ sub siblings {
- } else {
+ # Purpose: Returns a list of siblings
+ # Returns: List of object references
+ # Usage: @sibling = $obj->siblings;
- # 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;
- }
+ 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;
+ }
- if ($irv) {
+ return defined $parent ? $parent->children : ();
+ }
- # 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;
+ sub root {
- # Merge aliasas
- _mergeAliases( $parent, $orphan );
- }
+ # 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 $rv;
+ return $parent;
}
- sub _disassocObj ($@) {
+ sub _getRefById {
- # Purpose: Removes the child/parent relationship
- # Returns: Boolean
- # Usage: $rv = _disassocObj($parent, $child1, $child2):
+ # Purpose: Returns an object reference by id from the objects array
+ # Returns: Reference
+ # Usage: $obj = _getRefById($index);
- my $parent = CORE::shift;
- my @children = CORE::shift;
- my $child;
+ my $id = CORE::shift;
- foreach $child (@children) {
+ return defined $id ? $objects[$id][CEH_OREF] : undef;
+ }
- # 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] };
+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 );
+ }
+ }
- # Update the child's record
- $objects[$$child][CEH_PREF] = undef;
+ return $rv;
+}
- # Split aliases
- _spliceAliases( $parent, $child );
- }
+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 1;
}
- sub _cscope ($$) {
+ return $rv;
+}
- # 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);
+sub descendents {
- my $caller = CORE::shift;
- my $pkg = CORE::shift;
+ # Purpose: Returns all descendents of the object
+ # Returns: List of object references
+ # Usage: @descendents = $obj->descendents;
- # 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 '';
+ my $obj = CORE::shift;
+ my ( @children, @descendents, $child );
- return
- $caller eq $pkg ? CEH_PRIV
- : "$caller"->isa($pkg) ? CEH_RESTR
- : CEH_PUB;
+ 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;
+ }
}
- sub _chkAccess ($$$) {
+ return @descendents;
+}
- # 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);
+sub _initHierarchy {
- my $self = CORE::shift;
- my $caller = CORE::shift;
- my $prop = CORE::shift;
- my ( $opkg, $cscope, $pscope );
+ # Purpose: Initializes the object & class hierarchal data for an object
+ # Returns: Boolean
+ # Usage: $rv = _initHierarchy($obj, $class, @args);
- # Modify the property name for to check for private properties
- $prop = "${caller}::$prop"
- if defined $prop and !exists ${ $properties[$$self] }{$prop};
+ my $obj = CORE::shift;
+ my $class = CORE::shift;
+ my @args = @_;
+ my @classes = _getClasses($obj);
+ my ( $rv, $tclass, %classes );
- if ( defined $prop and CORE::exists ${ $properties[$$self] }{$prop} )
- {
+ # uniq the class list and save it
+ %classes = map { $_ => 0 } @classes;
- # Get the object package
- $opkg = $objects[$$self][CEH_PKG];
+ # Begin initialization from the top down
+ foreach $tclass ( reverse @classes ) {
+ unless ( $classes{$tclass} ) {
- # 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;
+ {
+ no strict 'refs';
- unless ( $cscope >= $pscope ) {
+ # call class _initialize()
+ $rv =
+ defined *{"${tclass}::_initialize"}
+ ? &{"${tclass}::_initialize"}( $obj, @args )
+ : 1;
- # 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";
+ # Track each class initialization so we only do
+ # it once
+ $classes{$tclass}++;
}
- return $prop;
+ last unless $rv;
}
- sub __declProp {
+ return $rv;
+}
- # Purpose: Registers list of properties as known
- # Returns: Boolean
- # Usage: $rv = __declProp($caller, $obj, $attr, @propNames);
+sub _destrHierarchy {
- my $caller = CORE::shift;
- my $obj = CORE::shift;
- my $attr = CORE::shift;
- my @names = splice @_;
- my $rv = 0;
- my $prop;
+ # Purpose: Destroys hierarchal data for an object
+ # Returns: Boolean
+ # Usage: $rv = _destrHierarchy($obj);
- if ( defined $attr ) {
- $rv = 1;
- @names = grep {defined} @names;
+ my $obj = CORE::shift;
+ my @classes = _getClasses($obj);
+ my $tclass;
- # 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}::$_" }
- }
+ # Attempt to run all the _deconstruct methods
+ {
+ no strict 'refs';
- 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;
- }
+ foreach $tclass ( reverse @classes ) {
+ &{"${tclass}::_deconstruct"}($obj)
+ if defined *{"${tclass}::_deconstruct"};
}
-
- return $rv;
}
- sub _declProp {
+ return 1;
+}
- # Purpose: Wrapper for __declProp, this is the public interface
- # Returns: RV of __declProp
- # Usage: $rv = __declProp($obj, $attr, @propNames);
+##########################################################
+# Alias support
+##########################################################
- my $caller = caller;
- my @args = splice @_;
+{
+
+ # Array of object aliases
+ my @aliases;
+
+ # Array of alias maps
+ my @amaps;
- return __declProp( $caller, @args );
+ 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 _loadProps($$) {
+ sub _destrAlias {
- # Purpose: Loads properties from @_properties
+ # Purpose: Destroys alias data for an object
# Returns: Boolean
- # Usage: $rv = _loadProps();
+ # Usage: $rv = _destrAlias($obj);
- my $class = CORE::shift;
my $obj = CORE::shift;
- my $rv = 1;
- my ( @_properties, $prop, $pname, $pattr, $pscope );
+ my $alias = $aliases[$$obj];
+ my $root = $obj->root;
- # Get the contents of the class array
- {
- no strict 'refs';
+ # Remove aliases from root alias map
+ delete $amaps[$$root]{$alias}
+ if defined $alias and $amaps[$$root]{$alias} == $$obj;
- @_properties = @{ *{"${class}::_properties"}{ARRAY} }
- if defined *{"${class}::_properties"};
- }
+ # 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 ) {
- # Process the list
- foreach $prop (@_properties) {
- next unless defined $prop;
+ # Skip objects without an alias
+ next unless defined $aliases[$$child];
- unless (
- __declProp( $class, $obj, @$prop[ CEH_ATTR, CEH_PPKG ] ) ) {
+ # 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;
- last;
+ } else {
+ $amaps[$$root]{$alias} = $$child;
}
- # 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] );
- }
+ # Store the child's prefered alias in its private index,
+ # regardless
+ $amaps[$$child] = { $alias => $$child };
}
return $rv;
}
- sub _setProp ($$@) {
+ sub _pruneAliases {
- # Purpose: Sets the designated property to the passed value(s).
- # Does some rough validation according to attributes
+ # Purpose: Removes all aliases from this object and its descendents
# 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];
+ # Usage: $rv = _prunAliases($obj);
- if ( not defined $val[0] ) {
+ my $obj = CORE::shift;
+ my $rv = 1;
+ my ( $root, $child, $alias );
- # Only allow undef values if the properties allow
- # undef values
- $rv = 1 if not $pundef;
+ $root = $obj->root;
+ foreach $child ( $obj, $obj->descendents ) {
- } else {
+ # We never prune aliases from an object's own index for itself
+ next if $$child == $$root;
- # 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";
- }
+ # 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;
}
- } 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};
+ 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 {
- ${ $properties[$$obj] }{$prop}[CEH_PVAL] = $val[0];
+
+ # 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 _getProp ($$) {
+ sub getByAlias {
- # 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');
+ # Purpose: Returns an object reference associated with a given name
+ # Returns: Reference
+ # Usage: $oref = $obj->getByAlias($alias);
- 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];
+ 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;
+ }
- # In this context only hashes and arrays need special handling
- return
- $pattr == CEH_ARRAY ? @$pval
- : $pattr == CEH_HASH ? %$pval
- : $pval;
+ return $rv;
}
- sub __declMethod {
+}
- # Purpose: Registers a list of methods as scoped
- # Returns: Boolean
- # Usage: $rv = __declMethod($class, $attr, @methods);
+##########################################################
+# Property/Method support
+##########################################################
- my $pkg = CORE::shift;
- my $attr = CORE::shift;
- my @names = splice @_;
- my ( $code, $method, $mfqn );
+{
- if ( defined $attr ) {
+ # Property storage
+ my @properties;
- # Quiet some warnings
- no warnings qw(redefine prototype);
- no strict 'refs';
+ sub __declProperty {
- foreach $method (@names) {
+ # Purpose: Creates a named property record with associated meta data
+ # Returns: Boolean
+ # Usage: $rv = __declProperty($caller, $obj, $name, $attr);
- # Get the fully qualified method name and associated code
- # block
- $mfqn = "${pkg}::${method}";
- $code = *{$mfqn}{CODE};
+ my $caller = CORE::shift;
+ my $obj = CORE::shift;
+ my $name = CORE::shift;
+ my $attr = CORE::shift;
- # Quick check to see if we've done this already -- if so
- # we skip to the next
- next if $methods{$mfqn};
+ # Prepend package scoping in front of private properties
+ $name = "$caller*$name" if $attr & CEH_PRIV;
- if ( defined $code ) {
+ # Apply default attributes
+ $attr |= CEH_SCALAR
+ unless ( $attr ^ CEH_PATTR_TYPE ) > 0;
+ $attr |= CEH_PUB
+ unless ( $attr ^ CEH_PATTR_SCOPE ) > 0;
- # Repackage
- if ( $attr == CEH_PRIV ) {
+ # 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;
- # Private methods
- *{$mfqn} = sub {
- my $caller = caller;
- goto &{$code} if $caller eq $pkg;
- croak 'Attempted to call private method '
- . "$method from $caller";
- };
+ return 1;
+ }
- } elsif ( $attr == CEH_RESTR ) {
+ sub _declProperty {
- # Restricted methods
- *{$mfqn} = sub {
- my $caller = caller;
- goto &{$code} if "$caller"->isa($pkg);
- croak 'Attempted to call restricted method '
- . "$method from $caller";
- };
- }
+ # 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);
- } else {
- croak "Method $method declared but not defined";
- }
+ my $obj = CORE::shift;
+ my $name = CORE::shift;
+ my $attr = CORE::shift;
+ my $caller = caller;
+ my $rv = !$obj->isStale;
- # Record our handling of this method
- $methods{$mfqn} = 1;
+ 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 1;
+ return $rv;
}
- sub _declMethod {
+ sub _gatekeeper {
- # Purpose: Wrapper for __declMethod, this is the public interface
- # Returns: RV of __declMethod
- # Usage: $rv = _declMethod($attr, @propNames);
+ # 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 $caller = caller;
- my @args = splice @_;
+ my $obj = CORE::shift;
+ my $caller = CORE::shift;
+ my $name = CORE::shift;
+ my ( $rv, $class, $cscope, $pscope );
- return __declMethod( $caller, @args );
- }
+ if ( defined $name and length $name ) {
- sub _loadMethods {
+ # Check scope and adjust for privately scoped properties
+ $name = "$caller*$name"
+ if CORE::exists $properties[$$obj]{"$caller*$name"};
- # Purpose: Loads methods from @_methods
- # Returns: Boolean
- # Usage: $rv = _loadMethods();
+ if ( CORE::exists $properties[$$obj]{$name} ) {
- my $class = CORE::shift;
- my $rv = 1;
- my ( @_methods, $method );
+ # Get the property's class
+ $class = $properties[$$obj]{$name}[CEH_PPKG];
- # Get the contents of the class array
- {
- no strict 'refs';
+ # Get the property's scope
+ $pscope =
+ $properties[$$obj]{$name}[CEH_PATTR] & CEH_PATTR_SCOPE;
- @_methods = @{ *{"${class}::_methods"}{ARRAY} }
- if defined *{"${class}::_methods"};
- }
+ # Get the caller's scope
+ $cscope =
+ $caller eq $class ? CEH_PRIV
+ : "$caller"->isa($class) ? CEH_RESTR
+ : CEH_PUB;
- # Process the list
- foreach $method (@_methods) {
- next unless defined $method;
- unless ( __declMethod( $class, @$method[ CEH_ATTR, CEH_PPKG ] ) )
- {
- $rv = 0;
- last;
+ # 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;
}
- # PUBLISHED METHODS
+ sub _setProperty {
- sub new ($;@) {
+ # Purpose: Sets the named property to the passed values
+ # Returns: Boolean
+ # Usage: $rv = $obj->_setProperty($name, @values);
- # Purpose: Object constructor
- # Returns: Object reference
- # Usage: $obj = Class->new(@args);
+ my $obj = CORE::shift;
+ my $name = CORE::shift;
+ my @val = @_;
+ my ( $rv, $ptype, $pundef, $pref );
- 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 );
+ # 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];
- # Set the id and register
- $$self = _ident();
- _regObj($self);
+ # Check for undef restrictions
+ $rv = 1 if !$pundef or defined $val[0];
- # 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__);
- }
+ 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;
}
- $n = scalar @classes - $l + 1;
- $l = scalar @classes;
- }
- # uniq the superclass list and save it
- %super = map { $_ => 0 } @classes;
+ } else {
- # Add our current package to the list
- CORE::unshift @classes, $class;
+ # No validation for array/hash types
+ $rv = 1;
+ }
- # Begin initialization from the top down
- foreach $tclass ( reverse @classes ) {
- unless ( $super{$tclass} ) {
+ # 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];
+ }
+ }
- # Save the class list for the desconstructor
- unshift @{ $objects[$$self][CEH_SUPER] }, $tclass;
+ return $rv;
+ }
- # First autoload @_properties & @_methods
- $rv = _loadProps( $tclass, $self ) && _loadMethods($tclass);
- unless ($rv) {
- _deregObj($self);
- $self = undef;
- last;
- }
+ sub set {
- # Last, call _initialize()
- $rv =
- defined *{"${tclass}::_initialize"}
- ? &{"${tclass}::_initialize"}( $self, @args )
- : 1;
+ # Purpose: Sets the named properties to the passed value(s)
+ # Returns: Boolean
+ # Usage: $rv = $obj->set($name, @values);
- # Track each super class initialization so we only do
- # it once
- $super{$tclass}++;
- }
+ my $obj = CORE::shift;
+ my $name = CORE::shift;
+ my @val = @_;
+ my $caller = caller;
+ my $rv = !$obj->isStale;
- unless ($rv) {
- _deregObj($self);
- $self = undef;
- last;
+ 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 $@;
}
- # Generate alias
- if ($self) {
- $alias = $objects[$$self][CEH_CNAME];
- $objects[$$self][CEH_ALIAS]{$alias} = $self;
- weaken $objects[$$self][CEH_ALIAS]{$alias};
- }
+ return $rv;
+ }
+
+ sub _getProperty {
- return $self;
+ # 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 parent ($) {
+ sub get {
- # Purpose: Returns a reference to the parent object
- # Returns: Object reference
- # Usage: $pref = $obj->parent;
+ # 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;
- my $self = CORE::shift;
+ 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 $objects[$$self][CEH_PREF];
+ return wantarray ? @rv : $rv[0];
}
- sub root ($) {
+ sub push {
- # Purpose: Returns a reference to the ancestral root of the object
- # tree
- # Returns: Object reference
- # Usage: $pref = $obj->root;
+ # Purpose: Performs a push operation on an array property
+ # Returns: RV of CORE::push or undef
+ # Usage: $rv = $obj->push($name, @values);
- my $self = CORE::shift;
- my ( $obj, $parent );
+ my $obj = CORE::shift;
+ my $name = CORE::shift;
+ my @val = @_;
+ my $caller = caller;
+ my $rv = !$obj->isStale;
- $obj = $self;
- while ( defined( $parent = $obj->parent ) ) {
- $obj = $parent;
+ 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 $obj;
+ return $rv;
}
- sub children ($) {
+ sub pop {
- # Purpose: Returns a list of object references to this object's
- # children
- # Returns: Array
- # Usage: @crefs = $obj->children;
+ # 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;
- my $self = CORE::shift;
+ 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 @{ $objects[$$self][CEH_CREF] };
+ return $rv;
}
- sub descendants ($) {
+ sub unshift {
- # Purpose: Returns a list of object references to all
- # (grand)children of this object
- # Returns: Array
- # Usage: @descendants = $obj->descendants;
+ # Purpose: Performs an unshift operation on an array property
+ # Returns: RV of CORE::unshift or undef
+ # Usage: $rv = $obj->unshift($name, @values);
- my $self = CORE::shift;
- my @children = @{ $objects[$$self][CEH_CREF] };
- my @rv = @children;
+ my $obj = CORE::shift;
+ my $name = CORE::shift;
+ my @val = @_;
+ my $caller = caller;
+ my $rv = !$obj->isStale;
- foreach (@children) {
- push @rv, $_->descendants;
+ 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;
+ return $rv;
}
- sub siblings ($) {
+ sub shift {
- # Purpose: Returns a list of object references to this object's
- # siblings
- # Returns: Array
- # Usage: @crefs = $obj->siblings;
+ # Purpose: Performs a shift operation on an array property
+ # Returns: RV of CORE::shift or undef
+ # Usage: $rv = $obj->shift($name);
- my $self = CORE::shift;
- my $pref = $objects[$$self][CEH_PREF];
- my @rv;
+ my $obj = CORE::shift;
+ my $name = CORE::shift;
+ my $caller = caller;
+ my $rv = !$obj->isStale;
- @rv = grep { $_ != $self } @{ $objects[$$pref][CEH_CREF] }
- if defined $pref;
+ 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;
+ return $rv;
}
- sub relative ($$) {
+ sub exists {
- # Purpose: Returns an object reference for an exact match on
- # an alias
- # Returns: Object reference
- # Usage: $oref = $obj->relative('foo');
+ # Purpose: Performs an exists operation on a hash property
+ # Returns: RV of CORE::exists or undef
+ # Usage: $rv = $obj->exists($name, $key);
- my $self = CORE::shift;
- my $alias = CORE::shift;
- my $rv;
+ my $obj = CORE::shift;
+ my $name = CORE::shift;
+ my $key = CORE::shift;
+ my $caller = caller;
+ my $rv = !$obj->isStale;
- if ( defined $alias ) {
- $rv = $objects[$$self][CEH_ALIAS]{$alias}
- if exists $objects[$$self][CEH_ALIAS]{$alias};
+ 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 relatives ($$) {
+ sub keys {
- # Purpose: Returns an object reference for an regex match on
- # an alias
- # Returns: Array
- # Usage: $oref = $obj->relatives('foo');
+ # Purpose: Performs a keys operation on a hash property
+ # Returns: RV of CORE::keys or empty array
+ # Usage: $rv = $obj->keys($name);
- my $self = CORE::shift;
- my $alias = CORE::shift;
- my ( @aliases, @rv );
+ my $obj = CORE::shift;
+ my $name = CORE::shift;
+ my $caller = caller;
+ my @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};
+ 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 alias ($;$) {
+ sub merge {
- # Purpose: Get/Set object alias
- # Returns: String/Boolean
- # Usage: $rv = $obj->alias;
+ # 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 $self = CORE::shift;
- my $alias = CORE::shift;
- my $rv;
+ my $obj = CORE::shift;
+ my $name = CORE::shift;
+ my %updates = @_;
+ my $rv = !$obj->isStale;
+ my $caller = caller;
+ my ( $k, $v );
- if ( defined $alias ) {
+ 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 $@;
+ }
- # Set alias
- if ( exists $objects[$$self][CEH_ALIAS]{$alias} ) {
+ return $rv;
+ }
- # Alias already in use -- fail
- $rv = 0;
+ sub subset {
- } else {
+ # 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);
- # 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;
+ 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 {
-
- # Get alias
- $rv = $objects[$$self][CEH_CNAME];
+ $@ = 'subset method called on a stale object';
+ carp $@;
}
- return $rv;
+ return @rv;
}
- sub adopt ($@) {
+ sub remove {
- # Purpose: Adopts the passed object references as children
+ # Purpose: Removes the ordinal or associated values from the named
+ # property
# Returns: Boolean
- # Usage: $rv = $obj->adopt($cobj1, $cobj2);
+ # Usage: $rv = $obj->remove($name, qw(foo bar));
+ # Usage: $rv = $obj->remove($name, 5, 8);
- my $self = CORE::shift;
- my @children = @_;
- my $rv = 0;
+ my $obj = CORE::shift;
+ my $name = CORE::shift;
+ my @keys = @_;
+ my $caller = caller;
+ my $rv = !$obj->isStale;
+ my ( $k, $l );
- $rv = _assocObj( $self, @children ) if @children;
+ 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 disown ($@) {
+ sub empty {
- # Purpose: Disowns the passed object references as children
+ # Purpose: Empties the named array or hash property
# Returns: Boolean
- # Usage: $rv = $obj->disown($cobj1, $cobj2);
+ # Usage: $rv = $obj->empty($name);
- 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 $obj = CORE::shift;
+ my $name = CORE::shift;
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 );
+ 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 {
-
- # get mode
- return _getProp( $self, $prop );
+ $@ = 'empty method called on a stale object';
+ carp $@;
}
- return 1;
+ return $rv;
}
- sub propertyNames ($) {
+ sub properties {
- # Purpose: Returns a list of all property names
- # Returns: Array
- # Usage: @names = $obj->propertyNames;
+ # Purpose: Returns a list of property names visible to the caller
+ # Returns: Array of scalars
+ # Usage: @names = $obj->properties;
- my $self = CORE::shift;
+ my $obj = CORE::shift;
my $caller = caller;
- my ( $opkg, $cscope, $pscope, @rv );
+ my @pnames = CORE::keys %{ $properties[$$obj] };
+ my @rv;
- # Get the object package
- $opkg = $objects[$$self][CEH_PKG];
+ # Populate with all the public properties
+ @rv =
+ grep { $properties[$$obj]{$_}[CEH_PATTR] & CEH_PUB } @pnames;
- # Property CORE::exists, check the caller & property scopes
- $cscope = _cscope( $caller, $opkg );
+ # 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;
+ }
- # 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;
+ # 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;
}
- # Array-specific methods
+ sub _initProperties {
- sub push ($$@) {
+ # Purpose: Initializes the property data for the object
+ # Returns: Boolean
+ # Usage: $rv = _initProperties($obj);
- # Purpose: pushes values onto the requested array property,
- # Returns: The return value of the CORE::push
- # Usage: $rv = $obj->push($prop, @values);
+ my $obj = CORE::shift;
+ my @classes = _getClasses($obj);
+ my $rv = 1;
+ my ( $class, @_properties, $prop, $pattr, $pscope, $pname );
- my $self = CORE::shift;
- my $prop = CORE::shift;
- my @values = splice @_;
- my $caller = caller;
- my $pattr;
+ # Initialize storage
+ $properties[$$obj] = {};
- # Check for access rights
- $prop = _chkAccess( $self, $caller, $prop );
+ # Load properties from top of class hierarchy down
+ foreach $class (@classes) {
- # 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;
+ # Get the contents of the class array
+ {
+ no strict 'refs';
- # push the values
- return CORE::push @{ ${ $properties[$$self] }{$prop}[CEH_PVAL] },
- @values;
- }
+ @_properties =
+ defined *{"${class}::_properties"}
+ ? @{ *{"${class}::_properties"}{ARRAY} }
+ : ();
+ }
- sub pop ($$) {
+ # Process the list
+ foreach $prop (@_properties) {
+ next unless defined $prop;
- # Purpose: pops values off of the requested array property,
- # Returns: The return value of CORE::pop
- # Usage: $rv = $obj->pop($prop);
+ unless (
+ __declProperty(
+ $class, $obj, @$prop[ CEH_PNAME, CEH_PATTR ] )
+ ) {
+ $rv = 0;
+ last;
+ }
- my $self = CORE::shift;
- my $prop = CORE::shift;
- my $caller = caller;
- my $pattr;
+ # 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] );
+ }
- # Check for access rights
- $prop = _chkAccess( $self, $caller, $prop );
+ last unless $rv;
+ }
- # 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] };
+ return $rv;
}
- sub unshift ($$@) {
+ sub _destrProperties {
- # 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;
+ # Purpose: Destroys the object's property data
+ # Returns: Boolean
+ # Usage: $rv = _destrProperties($obj);
- # Check for access rights
- $prop = _chkAccess( $self, $caller, $prop );
+ my $obj = CORE::shift;
- # 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;
+ $properties[$$obj] = undef;
- # unshift the values
- return CORE::unshift @{ ${ $properties[$$self] }{$prop}[CEH_PVAL] },
- @values;
+ return 1;
}
- sub shift ($$) {
+}
- # Purpose: shifts values off of the requested array property,
- # Returns: The return value of CORE::shift
- # Usage: $rv = $obj->shift($prop);
+{
+ my %classes; # Class => 1
+ my %methods; # Class::Method => 1
- my $self = CORE::shift;
- my $prop = CORE::shift;
- my $caller = caller;
- my $pattr;
+ sub __declMethod {
- # Check for access rights
- $prop = _chkAccess( $self, $caller, $prop );
+ # Purpose: Registers a list of methods as scoped
+ # Returns: Boolean
+ # Usage: $rv = __declMethod($class, $attr, $methods);
- # 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;
+ my $pkg = CORE::shift;
+ my $attr = CORE::shift;
+ my $method = CORE::shift;
+ my $rv = 1;
+ my ( $code, $mfqn );
- # shift the values
- return CORE::shift @{ ${ $properties[$$self] }{$prop}[CEH_PVAL] };
- }
+ if ( defined $attr and defined $method and length $method ) {
- # Hash-specific methods
+ # Quiet some warnings
+ no warnings qw(redefine prototype);
+ no strict 'refs';
- sub exists ($$$) {
+ # 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
- # Purpose: checks the existance of a key in the property hash
- # Returns: The return value of CORE::exists
- # Usage: $rv = $obj->exists($prop, $key);
+ } else {
+ $@ = 'invalid method declaration';
+ carp $@;
+ $rv = 0;
+ }
- my $self = CORE::shift;
- my $prop = CORE::shift;
- my $key = CORE::shift;
- my $caller = caller;
- my $pattr;
+ # Record our handling of this method
+ $methods{$mfqn} = 1 if $rv;
- # 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;
+ } else {
+ $@ = 'invalid method declaration';
+ carp $@;
+ $rv = 0;
+ }
- # Check for the key
- return CORE::exists ${ ${ $properties[$$self] }{$prop}[CEH_PVAL] }
- {$key};
+ return $rv;
}
- sub keys ($$) {
+ sub _declMethod {
- # Purpose: Retrieves a list of keys of the given hash property
- # Returns: The return value of CORE::keys
- # Usage: $rv = $obj->keys($prop, $key);
+ # Purpose: Wrapper for __declMethod, this is the public interface
+ # Returns: RV of __declMethod
+ # Usage: $rv = _declMethod($attr, @propNames);
- my $self = CORE::shift;
- my $prop = CORE::shift;
+ my $attr = CORE::shift;
+ my $method = CORE::shift;
my $caller = caller;
- my $pattr;
-
- # Check for access rights
- $prop = _chkAccess( $self, $caller, $prop );
+ my $rv = 1;
- # 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;
+ if ( defined $method and length $method ) {
+ $rv = __declMethod( $caller, $attr, $method );
+ } else {
+ $@ = '_declMethod function called with an invalid method';
+ carp $@;
+ $rv = 0;
+ }
- # Get the keys
- return CORE::keys %{ ${ $properties[$$self] }{$prop}[CEH_PVAL] };
+ return $rv;
}
- # Unified hash/array methods
-
- sub store ($$@) {
+ sub _initMethods {
- # Purpose: Adds elements to either an array or hash
+ # Purpose: Loads methods from @_methods
# 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 );
+ # Usage: $rv = _loadMethods();
- # Check for access rights
- $prop = _chkAccess( $self, $caller, $prop );
+ my $obj = CORE::shift;
+ my @classes = _getClasses($obj);
+ my $rv = 1;
+ my ( $class, @_methods, $method );
- # 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;
+ # Load methods from the top of the class hierarchy down
+ foreach $class (@classes) {
- if ( $pattr == CEH_HASH ) {
+ # Skip if the class has already been processed
+ next if CORE::exists $classes{$class};
- # Add the key-pairs
- %{ ${ $properties[$$self] }{$prop}[CEH_PVAL] } =
- ( %{ ${ $properties[$$self] }{$prop}[CEH_PVAL] }, @pairs );
+ # Get the contents of the class array
+ {
+ no strict 'refs';
- } else {
+ @_methods = @{ *{"${class}::_methods"}{ARRAY} }
+ if defined *{"${class}::_methods"};
+ }
- # Set the values to the specified indices
- while (@pairs) {
- $i = CORE::shift @pairs;
- $v = CORE::shift @pairs;
- ${ $properties[$$self] }{$prop}[CEH_PVAL][$i] = $v;
+ # 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 1;
+ return $rv;
}
- 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;
- }
+##########################################################
+# Class Constructors/Destructors
+##########################################################
- sub remove ($$@) {
+sub new {
- # 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};
- }
+ # 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;
- return 1;
- }
+ # Get the next available ID
+ $rv = _getID($obj);
- sub purge ($$) {
+ # Initialize alias support
+ $rv = _initAlias($obj) if $rv;
- # Purpose: Empties the specified hash or array property
- # Returns: Boolean
- # Usage: $obj->remove($prop);
+ # Initialize property scope support
+ $rv = _initProperties($obj) if $rv;
- my $self = CORE::shift;
- my $prop = CORE::shift;
- my @elements = splice @_;
- my $caller = caller;
- my ( $pattr, $i, @narray );
+ # Initialize method scope support
+ $rv = _initMethods($obj) if $rv;
- # Check for access rights
- $prop = _chkAccess( $self, $caller, $prop );
+ # Initialize the hierarchal code support
+ $rv = _initHierarchy( $obj, $class, @args ) if $rv;
- # 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;
+ return $rv ? $obj : undef;
+}
- ${ $properties[$$self] }{$prop}[CEH_PVAL] =
- $pattr == CEH_ARRAY ? [] : {};
+sub conceive {
- return 1;
- }
+ # Purpose: Same as new() but with hierarchal relationships pre-installed
+ # Returns: Reference
+ # Usage: SubClass->conceive($parent, @args);
- sub DESTROY ($) {
+ my $class = CORE::shift;
+ my $pobj = CORE::shift;
+ my @args = @_;
+ my $obj = bless \do { my $anon_scalar }, $class;
+ my $rv = 1;
- # Purpose: Walks the child heirarchy and releases all those
- # children before finally releasing this object
- # Returns: Boolean
- # Usage: $obj->DESTROY;
+ # Get the next available ID
+ $rv = _getID($obj) if $rv;
- my $self = CORE::shift;
- my ( @descendants, $child, $parent, $class );
+ # Adopt the object before we do anything else
+ $rv = $pobj->_adopt($obj) if $rv;
- if ( defined $objects[$$self] ) {
+ # Initialize property scope support
+ $rv = _initProperties($obj) if $rv;
- # 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;
- }
+ # Initialize method scope support
+ $rv = _initMethods($obj) if $rv;
- # Third, execute the _deconstruct from the bottom up
- no strict 'refs';
- foreach $class ( @{ $objects[$$self][CEH_SUPER] } ) {
- &{"${class}::_deconstruct"}($self)
- if defined *{"${class}::_deconstruct"};
- }
+ # Initialize the hierarchal code support
+ $rv = _initHierarchy( $obj, $class, @args ) if $rv;
- # Fourth, deregister object
- _deregObj($self);
- }
+ return $rv ? $obj : undef;
+}
- return 1;
+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;
@@ -1391,7 +1723,7 @@ Class::EHierarchy - Base class for hierarchally ordered objects
=head1 VERSION
-$Id: EHierarchy.pm,v 0.93 2013/07/07 00:17:27 acorliss Exp $
+$Id: lib/Class/EHierarchy.pm, 2.00 2017/01/09 08:47:12 acorliss Exp $
=head1 SYNOPSIS
@@ -1413,13 +1745,13 @@ $Id: EHierarchy.pm,v 0.93 2013/07/07 00:17:27 acorliss Exp $
);
sub _initalize {
- my $obj = shift;
+ my $obj = CORE::shift;
my %args = @_;
my $rv = 1;
# Statically defined properties and methods are
- # defined above. Dynamically generated/defined
- # poperties and methods can be done here.
+ # defined above. Dynamically generated
+ # properties and methods can be done here.
return $rv;
}
@@ -1432,196 +1764,111 @@ $Id: EHierarchy.pm,v 0.93 2013/07/07 00:17:27 acorliss Exp $
my $entry = new TelDirectory;
- $entry->property('first', 'John');
- $entry->property('last', 'Doe');
+ $entry->set('first', 'John');
+ $entry->set('last', 'Doe');
$entry->push('telephone', '555-111-2222', '555-555'5555');
=head1 DESCRIPTION
-B<Class::EHierarchy> is intended for use as a base class for custom objects,
-but objects that need one or more of the following features:
-
-=over
-
-=item * orderly bottom-up destruction of objects
-
-=item * opaque objects
-
-=item * class-based access restrictions for properties and methods
-
-=item * primitive strict property type awareness
-
-=item * alias-based object retrieval
-
-=back
-
-Each of the above features are described in more depth in the following
-subsections:
-
-=head2 ORDERLY DESTRUCTION
-
-Objects can I<adopt> other objects which creates a tracked relationship
-within the class itself. Those child objects can, in turn, adopt objects
-of their own. The result is a hierarchal tree of objects, with the parent
-being the trunk.
-
-Perl uses a reference-counting garbage collection system which destroys
-objects and data structures as the last reference to it goes out of scope.
-This results in an object being destroyed before any internal data structures
-or objects referenced internally. In most cases this works just fine since
-many programs really don't care how things are destroyed, just as long as they
-are.
-
-Occasionally, though, we do care. Take, for instance, a database-backed
-application that delays commits to the database until after all changes are
-made. Updates made to a collection of records can be flushed as as the parent
-object goes out of scope. In a regular object framework the parent object
-would be released, which could be a problem if it owned the database
-connection object. In this framework, though, the children are pre-emptively
-released first, triggering their DESTROY methods beforehand, in which the
-database commit is made:
-
- Database Object
- +--> Table1
- | +--> Row1
- | +--> Row2
- +--> Table2
- +--> Row1
-
-This, in a nutshell, is the primary purpose of this class.
-
-=head2 OPAQUE OBJECTS
-
-Objects based on this class will be opaque objects instead of the traditional
-blessed hash references in which the hash elements could be access directly
-through dereferencing. This prevents access to internal data structures
-outside of the published interface. This does mean, though, that you can't
-access your data directly, either. You must use a provided method to
-retrieve that data from the class storage.
-
-=head2 ACCESS RESTRICTIONS
-
-A benefit of having an opaque object is that allows for scoping of both
-properties and methods. This provides for the following access restrictions:
-
- private accessible only to members of this object's class
- restricted accessible to members of this object's class
- and subclasses
- public globally accessible
-
-Attempts to access either from outside the approved scope will cause the code
-to croak. There is an exception, however: private properties. This aren't
-just protected, they're hidden. This allows various subclasses to use the
-same names for internal properties without fear of name space violations.
-
-=head2 PROPERTY TYPE AWARENESS
-
-Properties can be explicitly declared to be of certain primitive data types.
-This allows some built in validation of values being set. Known scalar value
-types are scalar, code, glob, and reference.
-
-Properties can also house hashes and arrays. When this is leveraged it allows
-for properties contents to be managed in ways similar to their raw
-counterparts. You can retrieve individual elements, add, set, test for, and
-so on.
-
-=head2 ALIASES
-
-In a hierarchal system of object ownership the parent objects have strong
-references to their children. This frees you from having to code and track
-object references yourself. Sometimes, however, it's not always convenient or
-intuitive to remember which parent owns what objects when you have a
-multilevel hierarchy. Because of that this class implements an alias system
-to make retrieval simpler.
-
-Aliases are unique within each hierarchy or tree. Consider the following
-hierarchy in which every node is an object member:
-
- Application
- +--> Display
- | +--> Window1
- | | +--> Widget1
- | | +--> Widget2
- | | +--> Widget3
- | +--> Window2
- | +--> Widget1
- +--> Database Handle
- +--> Network Connections
-
-Giving each node a plain name, where it makes sense, makes it trivial for a
-widget to retrieve a reference to the database object to get or update data.
-
-Aliases can also be search via base names, making it trival to get a list of
-windows that may need to be updated in a display.
-
-=head1 SUBROUTINES/METHODS
-
-Subroutines and constants are provided strictly for use by derived classes
+B<Class::EHierarchy> is intended for use as a base class for objects that need
+support for class or object hierarchies. Additional features are also
+provided which can be useful for general property implementation and
+manipulation.
+
+=head2 OBJECT HIERARCHIES
+
+Object relationships are often implemented in application code, as well as the
+necessary reference storage to keep dependent objects in scope. This class
+attempts to relive the programmer of that necessity. To that end, the concept
+of an object hierarchy is implemented in this class.
+
+An OOP concept for RDBMS data, for instance, could be modeled as a collection
+of objects in the paradigm of a family tree. The root object could be your
+DBI connection handle, while all of the internal data structures as child
+objects:
+
+ DBH connection
+ +-> views
+ | +-> view1
+ +-> tables
+ +-> table1
+ +-> rows
+ | +-> row1
+ +-> columns
+
+Each type of object in the RDBMS is necessarily defined in context of the
+parent object.
+
+This class simplifies the formalization of these relationships, which can have
+a couple of benefits. Consider a row object that was retrieved, for example.
+If each of the columns was implmented as a property in the object one could
+allow in-memory modification of data with a delayed commit. When the
+connection goes out of scope you could code your application to flush those
+in-memory modifications back to the database prior to garbage collection.
+
+This is because garbage collection of an object causes a top-down destruction
+of the object tree (or, in the depiction above, bottom-up), with the farthest
+removed children reaped first.
+
+Another benefit of defined object hierarchies is that you are no longer
+required to keep track of and maintain references to every object in the
+tree. Only the root reference needs to be tracked since the root can also
+act as an object container. All children references can be retrieved at any
+time via method calls.
+
+An alias system is also implemented to make children retrieval even more
+convenient. Each table, for instance, could be aliased by their table name.
+That allows you to retrieve a table object by name, then, instead of iterating
+over the collection of tables until you find one with the attributes you're
+seeking.
+
+=head2 CLASS HIERARCHIES
+
+Class hierarchies are another concept meant to allieviate some of the tedium
+of coding subclasses. Traditionally, if you subclassed a class that required
+any significant initialization, particularly if it relied on internal data
+structures, you would be reduced to executing superclass constructors, then
+possibly executing code paths again to account for a few changed properties.
+
+This class explicitly separates assignment of properties from initialization,
+allowing you to execute those code paths only once. OOP implemenations of
+mathematical constructs, for instance, could significantly alter the values
+derived from objects simply by subclassing and overriding some property
+values. The original class' initializer will be run once, but using the new
+property values.
+
+In addition to that this class provides both property and method
+compartmentalization so that the original class author can limit the
+invasiveness of subclasses. Both methods and properties can be scoped to
+restrict access to both. You can restrict access to use by only the
+implementation class, to subclasses, or keep everything publically available.
+
+=head2 ADDITIONAL FEATURES
+
+The class hierarchal features necessarily make objects derived from this class
+opaque objects. Objects aren't blessed hashes, they are scalar references
+with all properties stored in class data structures.
+
+The property implementation was made to be flexible to accomodate most needs.
+A property can be a scalar value, but it also can be an array, hash, or a
+number of specific types of references.
+
+To make non-scalar properties almost as convenient as the raw data structures
+many core functions have been implemented as methods. This is not just a
+semantic convenience, it also has the benefit of working directly on the raw
+data stored in the class storage. Data structures aren't copied, altered, and
+stored, they are altered in place for performance.
+
+=head1 CONSTANTS
+
+Functions and constants are provided strictly for use by derived classes
within their defined methods. To avoid any confusion all of our exportable
symbols are *not* exported by default. You have to specifically import the
-B<all> tag set. Because these subroutines should not be used outside of the
-class they are all preceded by an underscore, like any other private function.
-
-Methods, on the other hand, are meant for direct and global use. With the
-exception of B<new> and B<DESTROY> they should all be safe to override.
-
-The following subroutines, methods, and/or constants are are orgnanized
-according to their functional domain (as outlined above).
-
-=head2 INSTANTIATION/DESTRUCTION
-
-All classes based on this class must use the I<new> constructor and I<DESTROY>
-deconstructor provided by this class. That said, subclasses still have an
-opportunity to do work in both phases.
-
-Before that, however, B<Class::EHierarchy> prepares the base object, defining
-and scoping properties and methods automatically based on the presence of
-class variables I<@_properties> and I<@_methods>:
-
- package Contact;
-
- use Class::EHierarchy qw(:all);
- use vars qw(@ISA @_properties @_methods);
-
- @ISA = qw(Class::EHierarchy);
- @_properties = (
- [ CEH_PUB | CEH_SCALAR, 'first' ],
- [ CEH_PUB | CEH_SCALAR, 'last' ],
- [ CEH_PUB | CEH_ARRAY, 'telephone' ],
- [ CEH_PUB | CEH_SCALAR, 'email' ],
- );
- @_methods = (
- [ CEH_PUB, 'full_name' ],
- );
-
- sub _initialize {
- my $obj = shift;
- my $rv = 1;
-
- ....
-
- return $rv;
- }
-
- sub _deconstruct {
- my $obj = shift;
- my $rv = 1;
-
- ....
-
- return $rv;
- }
-
- sub full_name {
- my $obj = shift;
-
- return $obj->property('first') . ' ' .
- $obj->property('last');
- }
+B<all> tag set. Because these functions should not be used outside of the
+subclass they are all preceded by an underscore, like any other private function.
-Both methods and properties are defined by their access scope. Properties
-also add in primitive data types. The constants used to designate these
-attributes are as follows:
+The following constants are provided for use in defining your properties and
+methods.
Scope
---------------------------------------------------------
@@ -1660,70 +1907,116 @@ Properties lacking a data type attribute default to B<CEH_SCALAR>. Likewise,
scope defaults to B<CEH_PUB>. Public methods can be omitted from I<@_methods>
since they will be assumed to be public.
-=head3 new
+Methods only support scoping for attributes. Data types and flags are not
+applicable to them.
+
+=head1 SUBROUTINES/METHODS
+
+=head2 new
+
+ $obj = new MyClass;
+
+All of the hierarchal features require bootstrapping in order to work. For
+that reason a constructor is provided which performs that work. If you wish
+to provide additional initialization you can place a B<_initialize> method in
+your class which will be called after the core bootstrapping is complete.
+
+=head2 _initialize
+
+ $rv = $obj->_initialize(@args);
+
+The use of this method is optional, but if present it will be called during
+the execution of the constructor. The boolean return value will determine if
+the constructor is successful or not. All superclasses with such a method
+will be called prior to the final subclass' method, allowing you to layer
+multiple levels of initialization.
+
+Initialization is performed I<after> the assignment of default values to
+properties. If your code is dependent on those values this allows you the
+opportunity to override certain defaults -- assuming they are visible to the
+subclass -- simply by setting those new defaults in the subclass.
+
+As shown, this method is called with all of the arguments passed to the
+constructor, and it expects a boolean return value.
+
+=head2 conceive
- $obj = Class::Foo->new(@args);
+ $child = MyClass->conceive($parent, @args);
-This method must not be overridden in any subclass, but be used as-is. That
-said, subclasses still have complete control over whether this method call
-succeeds via the B<_initialize> method, which all subclasses must provide
-themselves.
+B<conceive> is an alternate constructor that's intended for those subclasses
+with are dependent on relationships to parent objects during initialization.
-When the object contsructor is called an object is instantiated, then
-B<_initialize> is called with all of the B<new> arguments passed on unaltered.
-The B<_initialize> method is responsible for an internal initialization
-necessary as well as any validation. It must return a boolean value which
-determines whether a valid object reference is returned by the B<new> method,
-or undef.
+=head2 DESTROY
-B<NOTE:> all superclasses based on L<Class::EHierarchy> containing a
-B<_initialize> method will also be called, all prior to the current subclass'
-method.
+ $obj->DESTROY;
-=head3 _initialize
+Object hierarchal features require orderly destruction of children. For that
+purpose a B<DESTROY> method is provided which performs those tasks. If you
+have specific tasks you need performed prior to the final destruction of an
+object you can place a B<_deconstruct> method in your subclass.
- sub _initialize {
+=head2 _deconstruct
+
+ $rv = $obj->_desconstruct;
+
+B<_deconstruct> is an optional method which, if present, will be called during
+the object's B<DESTROY> phase. It will be called I<after> all children have
+completed thier B<DESTROY> phase. In keeping with the class hierarchal
+features all superclasses will have their B<_deconstruct> methods called after
+your subclass' method is called, but prior to finishing the B<DESTROY> phase.
+
+=head2 isStale
+
+ $rv = $obj->isStale;
+
+It is possible that you might have stored a reference to a child object in a
+tree. If you were to kick off destruction of the tne entire object tree by
+letting the root object's reference go out of scope the entire tree will be
+effectively destroyed. Your stored child reference will not prevent that from
+happening. At that point you effectively have a stale reference to a
+non-functioning object. This method allows you to detect that scenario.
+
+The primary use for this method is as part of your safety checks in your
+methods:
+
+ sub my_method {
my $obj = shift;
- my %args = @_; # or @args = $_;
- my $rv = 1;
+ my @args = @_;
+ my $rv = !$obj->isStale;
+
+ if ($rv) {
+
+ # Do method work here, update $rv, etc.
- # Random initialization stuff here
+ } else {
+ carp "called my_method on a stale object!";
+ }
return $rv;
}
-Once the basic object has been constructed it calls the I<_initialize> method,
-giving it a complete set of the arguments the constructor was called with.
-The form of those arguments, whether as an associative array or simple array,
-is up to the coder.
+It is important to note that this method is used in every public method
+provided by this base class. All method calls will therefore safely fail if
+called on a stale object.
-You can do whatever you want in this method, including creating and adopting
-child objects. You can also dynamically generate properties and methods using
-the I<_declProp> and I<_declMethod> class functions. Both are documented below.
+=head2 _declProp
-This method must return a boolean value. A false return value will cause the
-constructor to tear everything back down and return B<undef> to the caller.
+ $rv = _declProp($obj, CEH_PUB | CEH_SCALAR | CEH_NO_UNDEF, @propNames);
-=head3 _declProp
-
- $rv = _declProp($obj, SCOPE | TYPE | FLAG, @propNames);
-
-This function is used to create named properties while declaring they access
-scope and type.
+This function is used to dynamically create named properties while declaring
+their access scope and type.
Constants describing property attributes are OR'ed together, and only one
scope and one type from each list should be used at a time. Using multiple
types or scopes to describe any particular property will make it essentially
inaccessible.
-Type, if omitted, defaults to I<CEH_SCALAR>, Scope defaults to I<CEH_PUB>.
-
B<NOTE:> I<CEH_NO_UNDEF> only applies to psuedo-scalar types like proper
scalars, references, etc. This has no effect on array members or hash values.
-=head3 _declMethod
+=head2 _declMethod
- $rv = _declMethod($attr, @methods);
+ $rv = _declMethod(CEH_RESTR, @methods);
This function is is used to create wrappers for those functions whose access
you want to restrict. It works along the same lines as properties and uses
@@ -1736,46 +2029,7 @@ B<NOTE:> Since scoping is applied to the class symbol table (B<not> on a
per object basis) any given method can only be scoped once. That means you
can't do crazy things like make public methods private, or vice-versa.
-=head3 DESTROY
-
-A B<DESTROY> method is provided by this class and must not be overridden by
-any subclass. It is this method that provides the ordered termination
-property of hierarchal objects. Any code you wish to be executed during this
-phase can be put into a B<_deconstruct> method in your subclass. If it's
-available it will be executed after any children have been released.
-
-=head3 _deconstruct
-
- sub _deconstruct {
- my $obj = shift;
- my $rv = 1;
-
- # Do random cleanup stuff here
-
- return $rv;
- }
-
-This method is optional, but if needed must be provided by the subclass. It
-will be called during the B<DESTROY> phase of the object.
-
-=head2 ORDERLY DESTRUCTION
-
-In order for objects to be destroyed from the bottom up it is important to
-track the hierarchal relationship between them. This class uses a familial
-parent/child paradigm for doing so.
-
-In short, objects can I<adopt> and I<disown> other objects. Adopted objects
-become children of the parent object. Any object being destroyed preemptively
-triggers deconstruction routines on all of its children before cleaning up
-itself. This ensures that any child needing parental resources for final
-commits, etc., has those available.
-
-Additional methods are also present to make it easier for objects to interact
-with their immediate family of objects. Those are documented in this section.
-More powerful methods also exist as part of the alias system and are
-documented in their own section.
-
-=head3 adopt
+=head2 adopt
$rv = $obj->adopt($cobj1, $cobj2);
@@ -1784,7 +2038,7 @@ boolean value which is true only if all objects were successfully adopted.
Only subclasses for L<Class::EHierarchy> can be adopted. Any object that
isn't based on this class will cause this method to return a false value.
-=head3 disown
+=head2 disown
$rv = $obj->disown($cobj1, $cobj2);
@@ -1800,152 +2054,145 @@ You may still need to do this explicitly if your parent object manages objects
which may need to be released well prior to any garbage collection on the
parent.
-=head3 parent
+=head2 parent
$parent = $obj->parent;
This method returns a reference to this object's parent object, or undef if it
has no parent.
-=head3 children
+=head2 children
@crefs = $obj->children;
This method returns an array of object references to every object that was
adopted by the current object.
-=head3 descendants
+=head2 descendents
- @descendants = $obj->descendants;
+ @descendents = $obj->descendents;
This method returns an array of object references to every object descended
from the current object.
-=head3 siblings
+=head2 siblings
@crefs = $obj->siblings;
This method returns an array of object references to every object that shares
the same parent as the current object.
-=head3 root
+=head2 root
$root = $obj->root;
This method returns a reference to the root object in this object's ancestral
tree. In other words, the senior most parent in the current hierarchy.
-=head2 OPAQUE OBJECTS
+=head2 alias
-Opaque objects can't access their own data directly, and so must use methods
-to access them. There is one principle method for doing so, but note that in
-a later section a whole suite of convenience functions also exist to make hash
-and array property access easier.
+ $rv = $obj->alias($new_alias);
-=head3 property
+This method sets the alias for the object, returning a boolean value.
+This can be false if the proposed alias is already in use by another
+object in its hierarchy.
- $val = $obj->property('FooScalar');
- @val = $obj->property('FooArray');
- %val = $obj->property('FooHash');
- $rv = $obj->property('FooScalar', 'random text or reference');
- $rv = $obj->property('FooArray', @foo);
- $rv = $obj->property('FooHash', %foo);
+=head2 getByAlias
-This method provides a generic property accessor that abides by the scoping
-attributes given by B<_declProp>. This means that basic reference types are
-checked for during assignment, as well as flags like B<CEH_NO_UNDEF>.
+ $ref = $obj->getByAlias($name);
-A boolean value is returned on attempts to set values.
+This method returns an object reference from within the object's current
+object hierarchy by name. It will return undef if the alias is not in use.
-Any attempt to access a nonexistent property will cause the code to croak.
+=head2 set
-B<NOTE:> Given that the presence of additional arguments after the property
-name sets this method into 'write' mode, there is obviously no way to use this
-to empty a hash or array property. For that please see the L<purge> method
-below.
+ $rv = $obj->set('FooScalar', 'random text or reference');
+ $rv = $obj->set('FooArray', @foo);
+ $rv = $obj->set('FooHash', %foo);
-=head3 propertyNames
+This method provides a generic property write accessor that abides by the
+scoping attributes given by B<_declProp> or B<@_properties>. This means
+that basic reference types are checked for during assignment, as well as
+flags like B<CEH_NO_UNDEF>.
- @properties = $obj->propertyNames;
+=head2 get
-This method returns a list of all registered properties for the current
-object. Property names will be filtered appropriately by the caller's
-context.
+ $val = $obj->get('FooScalar');
+ @val = $obj->get('FooArray');
+ %val = $obj->get('FooHash');
-=head2 ACCESS RESTRICTIONS
+This method provides a generic property read accessor. This will return an
+undef for nonexistent properties.
-This section is actually covered as part of L<INSTANTIATION/DESTRUCTION>
-above.
+=head2 properties
-=head2 PROPERTY TYPE AWARENESS
+ @properties = $obj->properties;
-Properties are validated automatically on set attempts for the various scalar
-types (code, glob, reference, scalar value), as well as arrays and hashes.
-Working through a single accessor method for individual array or hash
-elements, however, can be very inconvenient. For that reason many common
-array/hash functions have been implemented as methods.
+This method returns a list of all registered properties for the current
+object. Property names will be filtered appropriately by the caller's
+context.
=head3 push
$rv = $obj->push($prop, @values);
This method pushes additional elements onto the specified array property.
-Calling this method on any non-array property will cause the program to croak.
-It returns the return value from the B<push> function.
+It returns the return value from the B<push> function, or undef on
+non-existent properties or invalid types.
=head3 pop
$rv = $obj->pop($prop);
-This method pops an element off of the specified array property. Calling
-this method on any non-array property will cause the program to croak. It
-returns the return value from the B<pop> function.
+This method pops an element off of the specified array property.
+It returns the return value from the B<pop> function, or undef on
+non-existent properties or invalid types.
=head3 unshift
$rv = $obj->unshift($prop, @values);
This method unshifts additional elements onto the specified array property.
-Calling this method on any non-array property will cause the program to croak.
-It returns the return value from the B<unshift> operation.
+It returns the return value from the B<unshift> function, or undef on
+non-existent properties or invalid types.
=head3 shift
$rv = $obj->shift($prop);
-This method shifts an element off of the specified array property. Calling
-this method on any non-array property will cause the program to croak. It
-returns the return value from the B<shift> operation.
+This method shifts an element off of the specified array property.
+It returns the return value from the B<shift> function, or undef on
+non-existent properties or invalid types.
=head3 exists
$rv = $obj->exists($prop, $key);
This method checks for the existance of the specified key in the hash
-property. Calling this method on any non-hash property will cause the program
-to croack. It returns the return value from the B<exists> function.
+property. It returns the return value from the B<exists> function, or
+undef on non-existent properties or invalid types.
=head3 keys
@keys = $obj->keys($prop);
-This method returns a list of keys from the specified hash property. Calling
-this method on any non-hash property will cause the program to croak. It
-returns the return value from the B<keys> function.
+This method returns a list of keys from the specified hash property.
+It returns the return value from the B<keys> function, or undef on
+non-existent properties or invalid types.
-=head3 store
+=head3 merge
- $obj->add($prop, foo => bar);
- $obj->add($prop, 4 => foo, 5 => bar);
+ $obj->merge($prop, foo => bar);
+ $obj->merge($prop, 4 => foo, 5 => bar);
This method is a unified method for storing elements in both hashes and
arrays. Hashes elements are simply key/value pairs, while array elements
-are provided as ordinal index/value pairs.
+are provided as ordinal index/value pairs. It returns a boolean value.
-=head3 retrieve
+=head3 subset
- @values = $obj->retrieve($hash, qw(foo bar) );
- @values = $obj->retrieve($array, 3 .. 5 );
+ @values = $obj->subset($hash, qw(foo bar) );
+ @values = $obj->subset($array, 3 .. 5 );
This method is a unified method for retrieving specific element(s) from both
hashes and arrays. Hash values are retrieved in the order of the specified
@@ -1969,36 +2216,12 @@ it to be poorly performing. You're better of retrieving the entire array
yourself via the B<property> method, splicing what you need, and calling
B<property> again to set the new array contents.
-=head3 purge
-
- $obj->purge($prop);
-
-This is a unified method for purging the contents of both array and hash
-properties.
-
-=head2 ALIASES
-
-=head3 alias
+=head3 empty
- $rv = $obj->alias($new_alias);
- $alias = $obj->alias;
-
-This method gets/sets the alias for the object. Gets always return a string,
-while sets return a boolean value. This can be false if the proposed alias is
-already in use by another object in its hierarchy.
-
-=head3 relative
-
- $oref = $obj->relative($name);
+ $rv = $obj->empty($name);
-This method retrieves the object known under the passed alias.
-
-=head3 relatives
-
- @orefs = $obj->relatives($name);
-
-This method retrieves a list of all objects with aliases beginning with the
-passed name.
+This is a unified method for emptying both array and hash properties. This
+returns a boolean value.
=head1 DEPENDENCIES
@@ -2006,40 +2229,6 @@ None.
=head1 BUGS AND LIMITATIONS
-As noted in the L<CREDIT> section below portions of the concept and
-implementation of opaque objects were taken from Damian Conway's module
-L<Class::Std(3)>. I have chosen to deviate from his implementation in a
-few key areas, and any or all of them might be considered bugs and/or
-limitations.
-
-Damian relies on an I<ident> function in his module to provide each module
-with a unique identifier. Unfortunately, when retrieving internal data
-structures he wants you to use them for each and every retrieval. While
-effective, this exercises the stack a bit more and provides a performance
-penalty.
-
-To avoid that penalty I chose to store the ID in the anonymous
-scalar we referenced as part of object instantiation. While in theory this
-could be overwritten and wreak havoc in the class data structures I think the
-performance benefits outweigh it. I am hedging that most of us won't
-accidentally dereference our object reference and overwrite it.
-
-Another benefit of storing the ID directly is that the code you'll write based
-on this class looks a lot more like traditional Perl OO. If you're a devout
-Damian disciple that's probably not a benefit, but his 'I<$attr_foo{ident
-$self}>' notation really rubs me the wrong way.
-
-Another performance concern I had with Class::Std was the heavy reliance on
-internal hashes. This penalizes you on both memory and performance
-utilization. So, I changed my internal I<_ident> function to be based purely
-on an ordinal index value, which allowed me to use arrays to store all of the
-applicable class data.
-
-End sum, this module gives you the hierarchal qualities I needed along with
-some of the opaque object benefits of L<Class::Std(3)>, but in a manner
-that possibly interferes less with one's natural style of coding while being
-generally more efficient and system friendly.
-
=head1 CREDIT
The notion and portions of the implementation of opaque objects were lifted
@@ -2055,5 +2244,5 @@ Arthur Corliss (corliss at digitalmages.com)
This software is licensed under the same terms as Perl, itself.
Please see http://dev.perl.org/licenses/ for more information.
-(c) 2009, Arthur Corliss (corliss at digitalmages.com)
+(c) 2017, Arthur Corliss (corliss at digitalmages.com)
diff --git a/t/01_ini.t b/t/01_init.t
similarity index 93%
rename from t/01_ini.t
rename to t/01_init.t
index 8e83ff7..50263bf 100644
--- a/t/01_ini.t
+++ b/t/01_init.t
@@ -1,4 +1,4 @@
-# 01_init_core.t
+# 01_init.t
#
# Tests for proper loading of the module
@@ -18,4 +18,3 @@ my $obj2 = new Class::EHierarchy;
ok( defined $obj2, 'Created object 2' );
ok( $$obj2 == 1, 'Verified object ID 2' );
-# end 01_init_core.t
diff --git a/t/02_object_hierarchy.t b/t/02_object_hierarchy.t
new file mode 100644
index 0000000..3422f6a
--- /dev/null
+++ b/t/02_object_hierarchy.t
@@ -0,0 +1,72 @@
+# 02_object_hierarchy.t
+#
+# Tests the tracking of object relationships
+
+use Test::More tests => 27;
+
+use strict;
+use warnings;
+
+use Class::EHierarchy;
+
+sub dumpObjInfo {
+ my $obj = shift;
+ my ( $id, $parent, $children );
+
+ $id = $$obj;
+ $parent = defined $obj->parent ? ${ $obj->parent } : 'undef';
+ $children = join ' ', map {$$_} $obj->children;
+
+ warn "ID $id: P: $parent C: $children\n";
+}
+
+my $obj1 = new Class::EHierarchy;
+my $obj2 = new Class::EHierarchy;
+my $obj3 = new Class::EHierarchy;
+my $obj4 = new Class::EHierarchy;
+
+# Test isStale
+$obj1->DESTROY;
+ok( $obj1->isStale, 'isStale 1' );
+ok( !$obj1->root, 'isStale 2' );
+ok( !$obj1->parent, 'isStale 3' );
+ok( !$obj1->children, 'isStale 4' );
+ok( !$obj1->siblings, 'isStale 5' );
+ok( !$obj1->descendents, 'isStale 6' );
+
+$obj1 = new Class::EHierarchy;
+is( $$obj1, 0, 'recover ID 1' );
+
+# Test basic adoption
+ok( !$obj1->adopt($obj1), 'Adopt Self 1' );
+ok( $obj1->adopt($obj2), 'Adopt Child 1' );
+is( $obj2->children, 0, 'Children 1' );
+is( $obj1->children, 1, 'Children 2' );
+ok( !$obj2->adopt($obj1), 'Adopt Parent 1' );
+ok( $obj2->adopt($obj3), 'Adopt Child 2' );
+is( $obj1->children, 1, 'Children 3' );
+is( $obj2->children, 1, 'Children 4' );
+is( $obj1->descendents, 2, 'descendents 1' );
+ok( !$obj3->adopt($obj1), 'Adopt Root 1' );
+
+# Test parent
+is( $obj1->parent, undef, 'Parent 1' );
+is( $obj3->parent, $obj2, 'Parent 2' );
+
+# Test root
+is( $obj1->root, $obj1, 'Root 1' );
+is( $obj3->root, $obj1, 'Root 2' );
+
+# Test descendents
+my @children = $obj1->descendents;
+is( $children[0], $obj2, 'descendent 1' );
+is( $children[1], $obj3, 'descendent 2' );
+
+# Adopt the root with obj4
+ok( $obj4->adopt($obj1), 'Adopt Child 3' );
+
+# Test disowning
+ok( $obj1->disown($obj2), 'Disown 1' );
+is( $obj1->children, 0, 'Children 6' );
+is( $obj2->parent, undef, 'Parent 3' );
+
diff --git a/t/02_relationships.t b/t/02_relationships.t
deleted file mode 100644
index d16eaf2..0000000
--- a/t/02_relationships.t
+++ /dev/null
@@ -1,105 +0,0 @@
-# 02_relationships.t
-#
-# Tests the tracking of object relationships
-
-use Test::More tests => 27;
-
-use strict;
-use warnings;
-
-use Class::EHierarchy;
-
-my $obj1 = new Class::EHierarchy;
-my $obj2 = new Class::EHierarchy;
-my $obj3 = new Class::EHierarchy;
-my $obj4 = new Class::EHierarchy;
-
-# Test basic adoption
-ok( !$obj1->adopt($obj1), 'Adopt Self' );
-ok( $obj1->adopt($obj2), 'Adopt Child 1' );
-my @children = $obj2->children;
-ok( !scalar @children, 'Children 1' );
- at children = $obj1->children;
-ok( scalar @children, 'Children 2' );
-ok( @children == 1, 'Children 3' );
-ok( !$obj2->adopt($obj1), 'Adopt Parent' );
-ok( $obj2->adopt($obj3), 'Adopt Child 2' );
- at children = $obj1->children;
-ok( @children == 1, 'Children 4' );
- at children = $obj2->children;
-ok( @children == 1, 'Children 5' );
-
-# Test parent
-ok( !defined $obj1->parent, 'Parent 1' );
-ok( $obj3->parent == $obj2, 'Parent 2' );
-
-# Test root
-ok( $obj3->root == $obj1, 'Root 1' );
-
-# Test descendants
- at children = $obj1->descendants;
-ok( $children[0] == $obj2, 'Descendant 1');
-ok( $children[1] == $obj3, 'Descendant 2');
-
-# Test disowning
-ok( $obj1->disown($obj2), 'Disown 1' );
- at children = $obj1->children;
-ok( @children == 0, 'Children 6' );
-ok( !defined $obj2->parent, 'Parent 3' );
-ok( $$obj1 == 0, 'Object ID 1' );
-
-Class::EHierarchy::_dumpDiags();
-
-# Test DESTROY routines
-$obj1 = undef;
-$obj4 = undef;
-$obj4 = new Class::EHierarchy;
-$obj1 = new Class::EHierarchy;
-ok( $$obj4 == 0, 'Object ID 2' );
-ok( $$obj1 == 3, 'Object ID 3' );
-ok( $obj2->adopt($obj4), 'Adopt Child 3' );
- at children = $obj2->children;
-ok( $obj3->adopt($obj1), 'Adopt Child 4' );
-ok( @children == 2, 'Children 7' );
-ok( !$obj1->adopt($obj2), 'Adopt Child 5' );
-$obj2 = undef;
-$obj3 = new Class::EHierarchy;
-ok( $$obj3 == 1, 'Object ID 4' );
-
-# Test subclassed adoption
-package Foo;
-
-sub new {
- my $class = shift;
- my $self = {};
-
- bless $self, $class;
-
- return $self;
-}
-
-1;
-
-package Bar;
-
-use vars qw(@ISA);
-
- at ISA = qw(Class::EHierarchy);
-
-1;
-
-package main;
-
-my $subobj1 = new Foo;
-my $subobj2 = new Bar;
-
-ok( !$obj3->adopt($subobj1), 'Adopt Child 7' );
-ok( $obj3->adopt($subobj2), 'Adopt Child 8' );
-
-$obj4 = $obj1 = undef;
-Class::EHierarchy::_dumpDiags();
-
-$obj1 = new Bar;
-Class::EHierarchy::_dumpDiags();
-
-# end 02_relationships.t
diff --git a/t/03_class_hierarchy.t b/t/03_class_hierarchy.t
new file mode 100644
index 0000000..94c4fb6
--- /dev/null
+++ b/t/03_class_hierarchy.t
@@ -0,0 +1,99 @@
+# 03_class_hierarchy.t
+#
+# Tests the hierarchal class initialization code
+
+use Test::More tests => 22;
+
+use strict;
+use warnings;
+
+our $counter1 = 0;
+our $counter2 = 0;
+
+package MyClass;
+
+use Class::EHierarchy qw(:all);
+use vars qw(@ISA);
+
+ at ISA = qw(Class::EHierarchy);
+
+sub _initialize {
+ my $obj = shift;
+
+ #warn "Initializing MyClass for $obj\n";
+ $counter1 = 200;
+}
+
+sub _deconstruct {
+ my $obj = shift;
+
+ #warn "Deconstructing MyClass for $obj\n";
+ $counter1 = 100;
+}
+
+package MySubClass;
+
+use Class::EHierarchy qw(:all);
+use vars qw(@ISA);
+
+ at ISA = qw(MyClass);
+
+sub _initialize {
+ my $obj = shift;
+
+ #warn "Initializing MySubClass for $obj\n";
+ $counter2 = $counter1**2;
+}
+
+sub _deconstruct {
+ my $obj = shift;
+
+ #warn "Deconstructing MySubClass for $obj\n";
+ $counter2 = $counter1 / 4;
+}
+
+package main;
+
+my @objects;
+my $obj1 = new MyClass;
+ok( $obj1, 'create parent 1' );
+is( $counter1, 200, 'counter1 check 1' );
+is( $counter2, 0, 'counter2 check 1' );
+my $obj2 = new MySubClass;
+ok( $obj2, 'create child 1' );
+ok( $obj1->adopt($obj2), 'adopt child 1' );
+is( $counter1, 200, 'counter1 check 2' );
+is( $counter2, 40000, 'counter2 check 2' );
+ at objects = Class::EHierarchy::_dumpObjects();
+is( @objects, 2, 'object count 1' );
+ at objects = ();
+$obj2 = undef;
+is( $counter1, 200, 'counter1 check 3' );
+is( $counter2, 40000, 'counter2 check 3' );
+ at objects = Class::EHierarchy::_dumpObjects();
+is( @objects, 2, 'object count 2' );
+ at objects = ();
+$obj1 = undef;
+is( $counter1, 100, 'counter1 check 4' );
+is( $counter2, 50, 'counter2 check 4' );
+ at objects = Class::EHierarchy::_dumpObjects();
+is( @objects, 0, 'object count 3' );
+ at objects = ();
+
+$obj1 = new MyClass;
+$obj2 = new MySubClass;
+ok( $obj1, 'create parent 2' );
+ok( $obj2, 'create child 2' );
+ok( $obj1->adopt($obj2), 'adopt child 2' );
+$obj2 = undef;
+ at objects = Class::EHierarchy::_dumpObjects();
+is( @objects, 2, 'object count 4' );
+ at objects = ();
+ok( $obj1->disown( $obj1->children ), 'disown child 1' );
+ at objects = Class::EHierarchy::_dumpObjects();
+is( @objects, 1, 'object count 5' );
+
+ok( MySubClass->conceive($obj1), 'conceive child 1' );
+ at objects = Class::EHierarchy::_dumpObjects();
+is( @objects, 2, 'object count 6' );
+
diff --git a/t/03_properties.t b/t/03_properties.t
deleted file mode 100644
index efa78aa..0000000
--- a/t/03_properties.t
+++ /dev/null
@@ -1,371 +0,0 @@
-# 03_properties.t
-#
-# Tests the various property types and scoping
-
-use Test::More tests => 92;
-
-use strict;
-use warnings;
-
-package Foo;
-
-use vars qw(@ISA);
-use Class::EHierarchy qw(:all);
-
- at ISA = qw(Class::EHierarchy);
-
-sub _initialize ($@) {
- my $self = shift;
- my @args = @_;
-
- _declProp( $self, CEH_PRIV | CEH_SCALAR, qw(PrivFoo) );
- _declProp( $self, CEH_PRIV | CEH_ARRAY, qw(PrivFooArray) );
- _declProp( $self, CEH_PRIV | CEH_HASH, qw(PrivFooHash) );
- _declProp( $self, CEH_RESTR | CEH_SCALAR, qw(RestrFoo) );
- _declProp( $self, CEH_RESTR | CEH_ARRAY, qw(RestrFooArray) );
- _declProp( $self, CEH_PUB | CEH_SCALAR, qw(PubFoo) );
-
- $self->property( 'PrivFoo', 'foo!' );
- $self->property( 'RestrFoo', 'rfoo!' );
- $self->property( 'PubFoo', 'pfoo!' );
- $self->property( 'PrivFooArray', qw(f1 f2 f3) );
- $self->property( 'RestrFooArray', qw(f11 f12 f13) );
- $self->property( 'PrivFooHash', qw(f1 one f2 two f3 three) );
-
- return 1;
-}
-
-sub call ($$$) {
- my $self = shift;
- my $obj = shift;
- my $prop = shift;
-
- return $obj->property( $prop, @_ );
-}
-
-sub cpurge ($$) {
- my $self = shift;
- my $prop = shift;
-
- return $self->purge($prop);
-}
-
-1;
-
-package Bar;
-
-use vars qw(@ISA);
-use Class::EHierarchy qw(:all);
-
- at ISA = qw(Class::EHierarchy);
-
-sub _initialize ($@) {
- my $self = shift;
- my @args = @_;
-
- _declProp( $self, CEH_PRIV | CEH_SCALAR, qw(PrivBar) );
- _declProp( $self, CEH_PRIV | CEH_ARRAY, qw(PrivBarArray) );
- _declProp( $self, CEH_PRIV | CEH_HASH, qw(PrivBarHash) );
- _declProp( $self, CEH_RESTR | CEH_SCALAR, qw(RestrBar) );
- _declProp( $self, CEH_RESTR | CEH_ARRAY, qw(RestrBarArray) );
- _declProp( $self, CEH_RESTR | CEH_HASH, qw(RestrBarHash) );
- _declProp( $self, CEH_PUB | CEH_CODE, qw(PubBar) );
-
- $self->property( 'PrivBar', 'bar!' );
- $self->property( 'RestrBar', 'rbar!' );
- $self->property( 'PubBar', 'pbar!' );
- $self->property( 'PrivBarArray', qw(b1 b2 b3 b4) );
- $self->property( 'RestrBarArray', qw(b11 b12 b13 b14) );
- $self->property( 'PrivBarHash', qw(b1 one b2 two b3 three) );
- $self->property( 'RestrBarHash', qw(b11 one b12 two b13 three) );
-
- return 1;
-}
-
-sub call ($$$) {
- my $self = shift;
- my $obj = shift;
- my $prop = shift;
-
- return $obj->property( $prop, @_ );
-}
-
-sub callNames ($$) {
- my $self = shift;
- my $obj = shift;
-
- return $obj->propertyNames;
-}
-
-sub cpurge ($$) {
- my $self = shift;
- my $prop = shift;
-
- return $self->purge($prop);
-}
-
-1;
-
-package Roo;
-
-use vars qw(@ISA);
-use Class::EHierarchy qw(:all);
-
- at ISA = qw(Bar);
-
-sub _initialize ($@) {
- my $self = shift;
- my @args = @_;
-
- _declProp( $self, CEH_PRIV | CEH_SCALAR, qw(PrivRoo PrivBar) );
- _declProp( $self, CEH_PRIV | CEH_ARRAY, qw(PrivBarArray) );
- _declProp( $self, CEH_RESTR | CEH_HASH, qw(RestrRooHash) );
- _declProp( $self, CEH_PUB | CEH_ARRAY, qw(PubArray) );
- _declProp( $self, CEH_PUB | CEH_HASH, qw(PubHash) );
- _declProp( $self, CEH_PUB | CEH_REF | CEH_NO_UNDEF, qw(PubRef) );
-
- $self->property( 'PrivRoo', 'roo!' );
- $self->property( 'PrivBar', 'roo-bar!' );
- $self->property( 'PrivBarArray', qw(r1) );
- $self->property( 'RestrRooHash', qw(r11 one r12 two r13 three) );
-
- return 1;
-}
-
-sub call ($$$) {
- my $self = shift;
- my $obj = shift;
- my $prop = shift;
-
- return $obj->property( $prop, @_ );
-}
-
-sub callNames ($$) {
- my $self = shift;
- my $obj = shift;
-
- return $obj->propertyNames;
-}
-
-sub cpurge ($$) {
- my $self = shift;
- my $prop = shift;
-
- return $self->purge($prop);
-}
-
-1;
-
-package main;
-
-my $class1a = new Foo;
-my $class1b = new Foo;
-my $class2a = new Bar;
-my $class2b = new Bar;
-my $class3a = new Roo;
-my $class3b = new Roo;
-
-my $rv;
-
-# Test subclass instantiation
-ok( defined $class1a, 'Created object for class Foo 1' );
-ok( defined $class1b, 'Created object for class Foo 2' );
-ok( $class1a->isa('Foo'), 'Verify class Foo 1' );
-ok( $class1a->isa('Class::EHierarchy'), 'Verify class Foo inheritance 1' );
-
-ok( defined $class2a, 'Created object for class Bar 1' );
-ok( defined $class2b, 'Created object for class Bar 2' );
-ok( $class2a->isa('Bar'), 'Verify class Bar 1' );
-ok( $class2a->isa('Class::EHierarchy'), 'Verify class Bar inheritance 1' );
-
-ok( defined $class3a, 'Created object for class Roo 1' );
-ok( defined $class3b, 'Created object for class Roo 2' );
-ok( $class3a->isa('Roo'), 'Verify class Roo 1' );
-ok( $class3a->isa('Class::EHierarchy'), 'Verify class Roo inheritance 1' );
-ok( $class3a->isa('Bar'), 'Verify class Roo inheritance 2' );
-
-# Set extra copies of objects to different property values
-ok( $class1b->call( $class1b, qw(PrivFoo nope!) ), 'Foo prep 1' );
-is( $class1b->call( $class1b, qw(PrivFoo) ), 'nope!', 'Foo prep validate 1' );
-ok( $class1b->call( $class1b, qw(RestrFoo nope) ), 'Foo prep 2' );
-is( $class1b->call( $class1b, qw(RestrFoo) ), 'nope', 'Foo prep validate 2' );
-ok( $class2b->call( $class2b, qw(PrivBar nope!) ), 'Bar prep 1' );
-is( $class2b->call( $class2b, qw(PrivBar) ), 'nope!', 'Bar prep validate 1' );
-ok( $class2b->call( $class2b, qw(RestrBar nope) ), 'Bar prep 2' );
-is( $class2b->call( $class2b, qw(RestrBar) ), 'nope', 'Bar prep validate 2' );
-ok( $class3b->call( $class3b, qw(PrivRoo nope!) ), 'Roo prep 1' );
-is( $class3b->call( $class3b, qw(PrivRoo) ), 'nope!', 'Roo prep validate 1' );
-ok( $class3b->call( $class3b, qw(PrivBar nope!) ), 'Roo prep 2' );
-is( $class3b->call( $class3b, qw(PrivBar) ), 'nope!', 'Roo prep validate 2' );
-
-# Scalar Private Property tests
-#
-# Call from same class should succeed
-is( $class1b->call( $class1a, qw(PrivFoo) ) , 'foo!',
- 'Foo Private Scalar Property Get 1' );
-is( $class2b->call( $class2a, qw(PrivBar) ) , 'bar!',
- 'Bar Private Scalar Property Get 1' );
-is( $class3b->call( $class3a, qw(PrivRoo) ) , 'roo!',
- 'Roo Private Scalar Property Get 1' );
-
-# Call from different class shoud fail
-$rv = eval '$class2a->call($class1a, qw(PrivFoo)); 1;';
-ok( !$rv, 'Bar calling Foo Private Scalar 1' );
-$rv = eval '$class1a->call($class2a, qw(PrivBar)); 1;';
-ok( !$rv, 'Foo calling Bar Private Scalar 1' );
-$rv = eval '$class3a->call($class2a, qw(PrivBar)); 1;';
-ok( !$rv, 'Roo calling Bar Private Scalar 1' );
-
-# Check class protection of private name collisions
-is( $class2b->call( $class3a, qw(PrivBar)), 'bar!', 'Class Collision 1' );
-is( $class3b->call( $class3a, qw(PrivBar)), 'roo-bar!', 'Class Collision 2' );
-ok( $class3b->call( $class3a, qw(PrivBar nrp-bar!) ), 'Class Collision 3' );
-ok( $class2b->call( $class3a, qw(PrivBar nbp-bar!) ), 'Class Collision 4' );
-is( $class2b->call( $class3a, qw(PrivBar)), 'nbp-bar!', 'Class Collision 5' );
-is( $class3b->call( $class3a, qw(PrivBar)), 'nrp-bar!', 'Class Collision 6' );
-
-# Scalar Restricted Property tests
-#
-# Calls from same class should succeed
-is( $class1b->call( $class1a, qw(RestrFoo) ) , 'rfoo!',
- 'Foo Restricted Scalar Property Get 1' );
-is( $class2b->call( $class2a, qw(RestrBar) ) , 'rbar!',
- 'Bar Restricted Scalar Property Get 1' );
-
-# Calls from subclasses should succeed
-is( $class3b->call( $class2a, qw(RestrBar) ) , 'rbar!',
- 'Bar Restricted Property Get 2' );
-is( $class3b->call( $class3a, qw(RestrBar) ) , 'rbar!',
- 'Bar Restricted Property Get 3' );
-
-# Calls from elsewhere should fail
-$rv = eval '$class1a->call($class2a, qw(RestrBar)); 1;';
-ok( !$rv, 'Foo calling Bar Restricted Scalar 1' );
-$rv = eval '$class2a->property(qw(RestrBar)); 1;';
-ok( !$rv, 'Main calling Bar Restricted Scalar 1' );
-
-# Set extra copies of objects to different property values
-ok( $class1b->cpurge( qw(PrivFooArray)), 'Foo prep 3' );
-$rv = [ $class1b->call( $class1b, qw(PrivFooArray)) ];
-is( scalar @$rv, 0, 'Foo prep validate 3' );
-ok( $class2b->cpurge( qw(PrivBarArray)), 'Bar prep 3' );
-$rv = [ $class2b->call( $class2b, qw(PrivBarArray)) ];
-is( scalar @$rv, 0, 'Bar prep validate 3' );
-ok( $class3b->cpurge( qw(PrivBarArray)), 'Roo prep 3' );
-$rv = [ $class3b->call( $class3b, qw(PrivBarArray)) ];
-is( scalar @$rv, 0, 'Roo prep validate 3' );
-
-# Array Private Property tests
-#
-# Call from same class should succeed
-$rv = [ $class1b->call( $class1a, qw(PrivFooArray)) ];
-is( scalar @$rv, 3, 'Foo Private Array Property Get 1' );
-is( $$rv[1], 'f2', 'Foo Private Array Property Get 2' );
-$rv = [ $class2b->call( $class2a, qw(PrivBarArray)) ];
-is( scalar @$rv, 4, 'Bar Private Array Property Get 1' );
-is( $$rv[1], 'b2', 'Bar Private Array Property Get 2' );
-$rv = [ $class3b->call( $class3a, qw(PrivBarArray)) ];
-is( scalar @$rv, 1, 'Roo Private Array Property Get 1' );
-is( $$rv[0], 'r1', 'Roo Private Array Property Get 2' );
-
-# Call from different class shoud fail
-$rv = eval '$class2a->call($class1a, qw(PrivFooArray)); 1;';
-ok( !$rv, 'Bar calling Foo Private Array 1' );
-$rv = eval '$class1a->call($class2a, qw(PrivBarArray)); 1;';
-ok( !$rv, 'Foo calling Bar Private Array 1' );
-$rv = eval '$class3a->call($class2a, qw(PrivBarArray)); 1;';
-ok( !$rv, 'Roo calling Bar Private Array 1' );
-
-# Array Restricted Property tests
-#
-# Calls from same class should succeed
-$rv = [ $class1b->call( $class1a, qw(RestrFooArray)) ];
-is( scalar @$rv, 3, 'Foo Restricted Array Property Get 1' );
-is( $$rv[1], 'f12', 'Foo Restricted Array Property Get 2' );
-$rv = [ $class2b->call( $class2a, qw(RestrBarArray)) ];
-is( scalar @$rv, 4, 'Bar Restricted Array Property Get 1' );
-is( $$rv[1], 'b12', 'Bar Restricted Array Property Get 2' );
-
-# Calls from subclasses should succeed
-$rv = [ $class3b->call( $class2a, qw(RestrBarArray)) ];
-is( scalar @$rv, 4, 'Bar from Roo Restricted Array Property Get 1' );
-is( $$rv[1], 'b12', 'Bar from Roo Restricted Array Property Get 2' );
-
-# Calls from elsewhere should fail
-$rv = eval '$class1b->call( $class2a, qw(RestrBarArray)); 1;';
-ok( !$rv, 'Foo calling Bar Restricted Array 1' );
-$rv = eval '$class3a->property(qw(RestrBarArray)); 1;';
-ok( !$rv, 'Main calling Roo Restricted Array 1' );
-
-# Set extra copies of objects to different property values
-ok( $class1b->cpurge( qw(PrivFooHash)), 'Foo prep 4' );
-$rv = [ $class1b->call( $class1b, qw(PrivFooHash)) ];
-is( scalar @$rv, 0, 'Foo prep validate 4' );
-ok( $class2b->cpurge( qw(PrivBarHash)), 'Bar prep 4' );
-$rv = [ $class2b->call( $class2b, qw(PrivBarHash)) ];
-is( scalar @$rv, 0, 'Bar prep validate 4' );
-
-# Hash Private Property tests
-#
-# Calls from same class should succeed
-$rv = { $class1b->call( $class1a, qw(PrivFooHash)) };
-is( $$rv{f1}, 'one', 'Foo Private Hash Property Get 1' );
-$rv = { $class2b->call( $class2a, qw(PrivBarHash)) };
-is( $$rv{b3}, 'three', 'Bar Private Hash Property Get 1' );
-
-# Call from different class shoud fail
-$rv = eval '$class2a->call($class1a, qw(PrivFooHash)); 1;';
-ok( !$rv, 'Bar calling Foo Private Hash 1' );
-$rv = eval '$class3a->call($class2a, qw(PrivBarHash)); 1;';
-ok( !$rv, 'Roo calling Bar Private Hash 1' );
-
-# Hash Restricted Property tests
-#
-# Calls from same class should succeed
-$rv = { $class3b->call( $class2a, qw(RestrBarHash)) };
-is( $$rv{b12}, 'two', 'Bar Restricted Hash Property Get 1' );
-
-# Calls from elsewhere should fail
-$rv = eval '$class1b->call( $class2a, qw(RestrBarHash)); 1;';
-ok( !$rv, 'Foo calling Bar Restricted Hash 1' );
-$rv = eval '$class2b->call( $class3a, qw(RestrRooHash)); 1;';
-ok( !$rv, 'Bar calling Roo Restricted Hash 1' );
-
-# Public array tests
-$rv = [ $class3a->property('PubArray') ];
-is( scalar @$rv, 0, 'Public Array Get 1' );
-$rv = $class3a->property( 'PubArray', qw(three two one) );
-ok( $rv, 'Public Array Set 1' );
-$rv = [ $class3a->property('PubArray') ];
-is( $$rv[0], 'three', 'Public Array Get 2' );
-
-# Public hash tests
-$rv = { $class3a->property('PubHash') };
-is( scalar keys %$rv, 0, 'Public Hash Get 1' );
-$rv = $class3a->property( 'PubHash', foo => 'bar' );
-ok( $rv, 'Public Hash Set 1' );
-$rv = { $class3a->property('PubHash') };
-is( scalar keys %$rv, 1, 'Public Hash Get 2' );
-is( $$rv{foo}, 'bar', 'Public Hash Get 3' );
-
-# Public ref tests
-$rv = $class3a->property('PubRef');
-is( $rv, undef, 'Public Ref Get 1' );
-$rv = $class3a->property( 'PubRef', qr/foo/ );
-ok( $rv, 'Public Ref Set 1' );
-$rv = $class3a->property('PubRef');
-is( $rv, qr/foo/, 'Public Ref Get 2' );
-$rv = $class3a->property( 'PubRef', undef );
-ok( !$rv, 'Public Ref Set 2' );
-$rv = $class3a->property('PubRef');
-is( $rv, qr/foo/, 'Public Ref Get 3' );
-
-# Test propertyNames
-my @names = $class1a->propertyNames;
-is( scalar @names, 1, 'Public Property Names 1' );
- at names = $class3b->callNames($class2a);
-is( scalar @names, 4, 'Restricted Property Names 1' );
- at names = $class2b->callNames($class2a);
-is( scalar @names, 7, 'Private Property Names 1' );
-
-# end 03_properties.t
diff --git a/t/04_alias.t b/t/04_alias.t
new file mode 100644
index 0000000..49f3f13
--- /dev/null
+++ b/t/04_alias.t
@@ -0,0 +1,98 @@
+# 04_alias.t
+#
+# Tests the tracking of object aliases
+
+use Test::More tests => 46;
+
+use strict;
+use warnings;
+
+use Class::EHierarchy;
+
+sub dumpObjInfo {
+ my $obj = shift;
+ my ( $id, $parent, $children );
+
+ $id = $$obj;
+ $parent = defined $obj->parent ? ${ $obj->parent } : 'undef';
+ $children = join ' ', map {$$_} $obj->children;
+
+ warn "ID $id: P: $parent C: $children\n";
+}
+
+my $obj1 = new Class::EHierarchy;
+my $obj2 = new Class::EHierarchy;
+my $obj3 = new Class::EHierarchy;
+my $obj4 = new Class::EHierarchy;
+
+# pre-flight
+ok( defined $obj1, 'instantiation 1' );
+ok( defined $obj2, 'instantiation 2' );
+ok( defined $obj3, 'instantiation 3' );
+ok( defined $obj4, 'instantiation 4' );
+
+# Pre-emptively apply aliases to 2 & 3
+ok( $obj2->alias('o2'), 'alias 1' );
+ok( $obj3->alias('o3'), 'alias 2' );
+
+# Test realiasing
+ok( !$obj3->alias('o33'), 'realias 1');
+
+# Check pre-adoption aliases
+is( $obj2->getByAlias('o2'), $obj2, 'pre-adoption alias 1');
+is( $obj3->getByAlias('o3'), $obj3, 'pre-adoption alias 2');
+
+# Build object hierarchy:
+# obj1 -> obj2 -> obj3, obj4
+ok( $obj2->adopt( $obj3, $obj4 ), 'adopt 1' );
+ok( $obj1->adopt($obj2), 'adopt 2' );
+
+# Test realiasing
+ok( !$obj3->alias('o33'), 'realias 2');
+
+# Test inherited aliases via every object
+is( $obj1->getByAlias('o2'), $obj2, 'get alias 1' );
+is( $obj2->getByAlias('o2'), $obj2, 'get alias 2' );
+is( $obj3->getByAlias('o2'), $obj2, 'get alias 3' );
+is( $obj4->getByAlias('o2'), $obj2, 'get alias 4' );
+is( $obj1->getByAlias('o3'), $obj3, 'get alias 5' );
+is( $obj2->getByAlias('o3'), $obj3, 'get alias 6' );
+is( $obj3->getByAlias('o3'), $obj3, 'get alias 7' );
+is( $obj4->getByAlias('o3'), $obj3, 'get alias 8' );
+
+# Test non-existent alias
+is( $obj1->getByAlias('o1'), undef, 'get alias 9' );
+is( $obj4->getByAlias(), undef, 'get alias 10' );
+
+# Alias o1 and o4
+ok( $obj1->alias('o1'), 'alias 1' );
+ok( $obj4->alias('o4'), 'alias 2' );
+
+# Test new aliases via every object
+is( $obj1->getByAlias('o1'), $obj1, 'get alias 11' );
+is( $obj2->getByAlias('o1'), $obj1, 'get alias 12' );
+is( $obj3->getByAlias('o1'), $obj1, 'get alias 13' );
+is( $obj4->getByAlias('o1'), $obj1, 'get alias 14' );
+is( $obj1->getByAlias('o4'), $obj4, 'get alias 15' );
+is( $obj2->getByAlias('o4'), $obj4, 'get alias 16' );
+is( $obj3->getByAlias('o4'), $obj4, 'get alias 17' );
+is( $obj4->getByAlias('o4'), $obj4, 'get alias 18' );
+
+# Disown o3 and test aliases again
+ok( $obj2->disown($obj3), 'disown 1' );
+is( $obj1->getByAlias('o3'), undef, 'get alias 19');
+is( $obj4->getByAlias('o3'), undef, 'get alias 19');
+is( $obj1->getByAlias('o2'), $obj2, 'get alias 20');
+is( $obj4->getByAlias('o2'), $obj2, 'get alias 21');
+is( $obj3->getByAlias('o1'), undef, 'get alias 22');
+is( $obj3->getByAlias('o3'), $obj3, 'get alias 23');
+
+# Disown o2 and test aliases
+ok( $obj1->disown($obj2), 'disown 2');
+is($obj1->getByAlias('o2'), undef, 'get alias 24');
+is($obj1->getByAlias('o4'), undef, 'get alias 25');
+is($obj1->getByAlias('o1'), $obj1, 'get alias 26');
+is($obj2->getByAlias('o2'), $obj2, 'get alias 27');
+is($obj2->getByAlias('o4'), $obj4, 'get alias 28');
+is($obj4->getByAlias('o2'), $obj2, 'get alias 29');
+
diff --git a/t/04_array_methods.t b/t/04_array_methods.t
deleted file mode 100644
index 97f53e0..0000000
--- a/t/04_array_methods.t
+++ /dev/null
@@ -1,128 +0,0 @@
-# 04_array_methods.t
-#
-# Tests the array property methods
-
-use Test::More tests => 41;
-
-use strict;
-use warnings;
-
-package Foo;
-
-use vars qw(@ISA);
-use Class::EHierarchy qw(:all);
-
- at ISA = qw(Class::EHierarchy);
-
-sub _initialize ($@) {
- my $self = shift;
- my @args = @_;
-
- _declProp( $self, CEH_PRIV | CEH_ARRAY, qw(PrivArray) );
- _declProp( $self, CEH_PUB | CEH_ARRAY, qw(PubArray) );
- _declProp( $self, CEH_PRIV | CEH_HASH, qw(PrivHash) );
- _declProp( $self, CEH_PUB | CEH_HASH, qw(PubHash) );
-
- return 1;
-}
-
-1;
-
-package main;
-
-my $obj = new Foo;
-my $rv;
-
-# Test methods against a private property
-$rv = eval '$obj->push(qw(PrivArray one two three)); 1;';
-ok( !$rv, 'Private push 1' );
-$rv = eval '$obj->pop(qw(PrivArray)); 1;';
-ok( !$rv, 'Private pop 1' );
-$rv = eval '$obj->unshift(qw(PrivArray one two three)); 1;';
-ok( !$rv, 'Private unshift 1' );
-$rv = eval '$obj->shift(qw(PrivArray)); 1;';
-ok( !$rv, 'Private shift 1' );
-
-# Test methods against a hash property
-$rv = eval '$obj->push(qw(PubHash one two three)); 1;';
-ok( !$rv, 'Hash push 1' );
-$rv = eval '$obj->pop(qw(PubHash)); 1;';
-ok( !$rv, 'Hash pop 1' );
-$rv = eval '$obj->unshift(qw(PubHash one two three)); 1;';
-ok( !$rv, 'Hash unshift 1' );
-$rv = eval '$obj->shift(qw(PubHash)); 1;';
-ok( !$rv, 'Hash shift 1' );
-
-# Test array methods against a public property
-#
-# Push
-$rv = $obj->push(qw(PubArray one two three));
-ok( $rv, 'Public push 1' );
-$rv = [ $obj->property('PubArray') ];
-is( scalar @$rv, 3, 'Public push verify 1' );
-is( $$rv[1], 'two', 'Public push verify 2' );
-
-# Pop
-$rv = $obj->pop(qw(PubArray));
-is( $rv, 'three', 'Public pop 1' );
-$rv = [ $obj->property('PubArray') ];
-is( scalar @$rv, 2, 'Public pop verify 1' );
-is( $$rv[1], 'two', 'Public pop verify 2' );
-
-# Unshift
-$rv = $obj->unshift(qw(PubArray a b c));
-ok( $rv, 'Public unshift 1' );
-$rv = [ $obj->property('PubArray') ];
-is( scalar @$rv, 5, 'Public unshift verify 1' );
-is( $$rv[1], 'b', 'Public unshift verify 2' );
-is( $$rv[3], 'one', 'Public unshift verify 3' );
-
-# Shift
-$rv = $obj->shift(qw(PubArray));
-is( $rv, 'a', 'Public shift 1' );
-$rv = [ $obj->property('PubArray') ];
-is( scalar @$rv, 4, 'Public shift verify 1' );
-is( $$rv[1], 'c', 'Public shift verify 2' );
-
-# Test unified methods against a public property
-#
-# Store
-$rv = $obj->store(qw(PubArray 5 foo 6 bar));
-ok( $rv, 'Public store 1' );
-$rv = [ $obj->property('PubArray') ];
-is( scalar @$rv, 7, 'Public store verify 1' );
-is( $$rv[4], undef, 'Public store verify 2' );
-is( $$rv[5], 'foo', 'Public store verify 3' );
-$rv = $obj->store(qw(PubArray foo 5 bar 6));
-ok( $rv, 'Public store 2' );
-$rv = [ $obj->property('PubArray') ];
-is( scalar @$rv, 7, 'Public store verify 4' );
-is( $$rv[0], 6, 'Public store verify 5' );
-
-# Retrieve
-$rv = [ $obj->retrieve('PubArray', 3 .. 5) ];
-is( scalar @$rv, 3, 'Public retrieve verify 1' );
-is( $$rv[1], undef, 'Public retrieve verify 2' );
-is( $$rv[2], 'foo', 'Public retrieve verify 3' );
-$rv = [ $obj->retrieve('PubArray', 3 .. 8) ];
-is( scalar @$rv, 6, 'Public retrieve verify 4' );
-is( $$rv[5], undef, 'Public retrieve verify 5' );
-$rv = [ $obj->retrieve('PubArray', 3 ) ];
-is( scalar @$rv, 1, 'Public retrieve verify 6' );
-is( $$rv[0], 'two', 'Public retrieve verify 7' );
-
-# Remove
-$rv = $obj->remove(qw(PubArray 4 5));
-ok( $rv, 'Public remove 1' );
-$rv = [ $obj->property('PubArray') ];
-is( scalar @$rv, 5, 'Public remove verify 1' );
-is( $$rv[4], 'bar', 'Public remove verify 2' );
-is( $$rv[3], 'two', 'Public remove verify 2' );
-
-# Purge
-$rv = $obj->purge(qw(PubArray));
-ok( $rv, 'Public purge 1' );
-$rv = [ $obj->property('PubArray') ];
-is( scalar @$rv, 0, 'Public purge verify 1' );
-
-# end 04_array_methods.t
diff --git a/t/05_hash_methods.t b/t/05_hash_methods.t
deleted file mode 100644
index 30aa36c..0000000
--- a/t/05_hash_methods.t
+++ /dev/null
@@ -1,99 +0,0 @@
-# 05_hash_methods.t
-#
-# Tests the hash property methods
-
-use Test::More tests => 25;
-
-use strict;
-use warnings;
-no warnings 'uninitialized';
-
-package Foo;
-
-use vars qw(@ISA);
-use Class::EHierarchy qw(:all);
-
- at ISA = qw(Class::EHierarchy);
-
-sub _initialize ($@) {
- my $self = shift;
- my @args = @_;
-
- _declProp( $self, CEH_PRIV | CEH_ARRAY, qw(PrivArray) );
- _declProp( $self, CEH_PUB | CEH_ARRAY, qw(PubArray) );
- _declProp( $self, CEH_PRIV | CEH_HASH, qw(PrivHash) );
- _declProp( $self, CEH_PUB | CEH_HASH, qw(PubHash) );
-
- return 1;
-}
-
-1;
-
-package main;
-
-my $obj = new Foo;
-my $rv;
-
-# Test methods against a private property
-$rv = eval '$obj->exists(qw(PrivHash one)); 1;';
-ok( !$rv, 'Private exists 1' );
-$rv = eval '$obj->keys(qw(PrivHash)); 1;';
-ok( !$rv, 'Private keys 1' );
-
-# Test methods against a array property
-$rv = eval '$obj->exists(qw(PubArray one)); 1;';
-ok( !$rv, 'Array exists 1' );
-$rv = eval '$obj->keys(qw(PubArray)); 1;';
-ok( !$rv, 'Array keys 1' );
-
-# Test hash methods against a public property
-#
-# Exists
-$obj->property(qw(PubHash one 1 two 2 three 3));
-$rv = $obj->exists(qw(PubHash two));
-ok( $rv, 'Public exists 1' );
-$rv = { $obj->property('PubHash') };
-is( scalar keys %$rv, 3, 'Public exists verify 1' );
-is( $$rv{two}, 2, 'Public exists verify 2' );
-$rv = $obj->exists(qw(PubHash foo));
-ok( !$rv, 'Public exists 2' );
-
-# Keys
-$rv = [ sort $obj->keys(qw(PubHash)) ];
-is( scalar @$rv, 3, 'Public keys 1' );
-is( $$rv[1], 'three', 'Public keys verify 1' );
-
-# Test unified methods against a public property
-#
-# Store
-$rv = $obj->store(qw(PubHash four 4 five 5));
-ok( $rv, 'Public store 1' );
-$rv = [ sort $obj->keys('PubHash') ];
-is( scalar @$rv, 5, 'Public store verify 1' );
-is( $$rv[3], 'three', 'Public store verify 2' );
-
-# Retrieve
-$rv = [ sort $obj->retrieve(qw(PubHash four two)) ];
-is( scalar @$rv, 2, 'Public retrieve verify 1' );
-is( $$rv[0], 2, 'Public retrieve verify 2' );
-is( $$rv[1], 4, 'Public retrieve verify 3' );
-$rv = [ sort $obj->retrieve(qw(PubHash three foo five)) ];
-is( scalar @$rv, 3, 'Public retrieve verify 2' );
-is( $$rv[0], undef, 'Public retrieve verify 4' );
-is( $$rv[1], 3, 'Public retrieve verify 5' );
-
-# Remove
-$rv = $obj->remove(qw(PubHash two three));
-ok( $rv, 'Public remove 1' );
-$rv = [ sort $obj->keys('PubHash') ];
-is( scalar @$rv, 3, 'Public remove verify 1' );
-is( $$rv[0], 'five', 'Public remove verify 2' );
-is( $$rv[1], 'four', 'Public remove verify 2' );
-
-# Purge
-$rv = $obj->purge(qw(PubHash));
-ok( $rv, 'Public purge 1' );
-$rv = [ $obj->keys('PubHash') ];
-is( scalar @$rv, 0, 'Public purge verify 1' );
-
-# end 05_hash_methods.t
diff --git a/t/05_properties.t b/t/05_properties.t
new file mode 100644
index 0000000..0077257
--- /dev/null
+++ b/t/05_properties.t
@@ -0,0 +1,221 @@
+# 05_properties.t
+#
+# Tests the various property types and scoping
+
+use Test::More tests => 61;
+
+use strict;
+use warnings;
+
+package MyPi;
+
+use vars qw(@ISA @_properties);
+use Class::EHierarchy qw(:all);
+
+ at ISA = qw(Class::EHierarchy);
+
+ at _properties = (
+ [ CEH_PUB | CEH_SCALAR, 'pi', 3.14 ],
+ [ CEH_RESTR | CEH_SCALAR, '2xpi' ],
+ [ CEH_PRIV | CEH_SCALAR, '3xpi' ],
+ );
+
+sub _initialize {
+ my $self = shift;
+ my @args = @_;
+
+ # Initialize the double/triple PIs
+ $self->set( '2xpi', $self->get('pi') * 2 );
+ $self->set( '3xpi', $self->get('pi') * 3 );
+
+ return 1;
+}
+
+sub double {
+ my $self = shift;
+ return $self->get('2xpi');
+}
+
+sub triple {
+ my $self = shift;
+ return $self->get('3xpi');
+}
+
+sub dump {
+ my $self = shift;
+ return $self->properties;
+}
+
+1;
+
+package MySquaredPi;
+
+use vars qw(@ISA @_properties);
+use Class::EHierarchy qw(:all);
+
+ at ISA = qw(MyPi);
+
+ at _properties = (
+ [ CEH_PUB | CEH_SCALAR, 'pi', 3.14**2 ],
+ [ CEH_PUB | CEH_SCALAR, 'custompi' ],
+ [ CEH_PUB | CEH_SCALAR | CEH_NO_UNDEF, 'noundef', 5 ],
+ [ CEH_PUB | CEH_REF, 'ref' ],
+ [ CEH_PUB | CEH_GLOB, 'glob' ],
+ [ CEH_PUB | CEH_CODE, 'code' ],
+ [ CEH_PUB | CEH_ARRAY, 'array' ],
+ [ CEH_PUB | CEH_HASH, 'hash' ],
+ );
+
+sub _initialize {
+ my $self = shift;
+ my @args = @_;
+
+ $self->set( 'custompi', $self->get('pi') * $args[0] );
+
+ return 1;
+}
+
+sub double {
+ my $self = shift;
+ return $self->get('2xpi');
+}
+
+sub triple {
+ my $self = shift;
+ return $self->get('3xpi');
+}
+
+sub dynprop {
+ my $self = shift;
+ _declProperty( $self, '5xpi', CEH_PRIV | CEH_SCALAR );
+ return $self->set( '5xpi', $self->get('pi') * 5 );
+}
+
+sub quintuple {
+ my $self = shift;
+ return $self->get('5xpi');
+}
+
+sub dump {
+ my $self = shift;
+ return $self->properties;
+}
+
+1;
+
+package MyRedundantPi;
+
+use vars qw(@ISA);
+use Class::EHierarchy qw(:all);
+
+ at ISA = qw(MyPi);
+
+1;
+
+package main;
+
+my $mypi = new MyPi;
+my $mysqpi = new MySquaredPi 12;
+my $myrpi = new MyRedundantPi;
+my $rv;
+
+# Create our objects
+ok( defined $mypi, 'class object instantiation - 1' );
+ok( defined $mysqpi, 'subclass object instantiation - 1' );
+ok( defined $myrpi, 'subclass object instantiation - 2' );
+
+# Check the public property values
+is( $mypi->get('pi'), 3.14, 'public property - 1' );
+is( $mysqpi->get('pi'), 3.14**2, 'overriden public property - 1' );
+is( $myrpi->get('pi'), 3.14, 'inherited public property - 1' );
+
+# Check restricted property values
+is( $mypi->get('2xpi'), undef, 'restricted property - 1' );
+is( $mypi->double, 3.14 * 2, 'restricted property - 2' );
+is( $mysqpi->get('2xpi'), undef, 'restricted property - 3' );
+is( $mysqpi->double, 3.14**2 * 2, 'restricted property - 4' );
+is( $myrpi->get('2xpi'), undef, 'restricted property - 5' );
+is( $myrpi->double, 3.14 * 2, 'restricted property - 6' );
+
+# Check private property values
+is( $mypi->get('3xpi'), undef, 'private property - 1' );
+is( $mypi->triple, 3.14 * 3, 'private property - 2' );
+is( $mysqpi->get('3xpi'), undef, 'private property - 3' );
+is( $mysqpi->triple, undef, 'private property - 4' );
+is( $myrpi->get('3xpi'), undef, 'private property - 5' );
+is( $myrpi->triple, 3.14 * 3, 'private property - 6' );
+
+# Safety check
+is( $mypi->get('MyPi*3xpi'), undef, 'private property - 7' );
+
+# Check arg initialization code
+is( $mysqpi->get('custompi'), 3.14**2 * 12, 'arg init property - 1' );
+
+# Check dynamic property
+ok( $mysqpi->dynprop, 'dynamic property - 1' );
+is( $mysqpi->get('5xpi'), undef, 'private property - 8' );
+is( $mysqpi->quintuple, 3.14**2 * 5, 'private property - 9' );
+
+# Test noundef
+ok( !$mysqpi->set( 'noundef', undef ), 'no undef - 1' );
+is( $mysqpi->get('noundef'), 5, 'no undef - 2' );
+ok( $mysqpi->set( 'noundef', 100 ), 'no undef - 3' );
+is( $mysqpi->get('noundef'), 100, 'no undef - 4' );
+ok( !$mysqpi->set( 'noundef', $mypi ), 'no ref - 1' );
+
+# Test code refs
+my $sub = sub {1};
+ok( !$mysqpi->set( 'code', 21 ), 'code - 1' );
+ok( $mysqpi->set( 'code', $sub ), 'code - 2' );
+is( $mysqpi->get('code'), $sub, 'code - 3' );
+ok( $mysqpi->set('code'), 'code - 4' );
+is( $mysqpi->get('code'), undef, 'code - 5' );
+
+# Test glob refs
+ok( !$mysqpi->set( 'glob', 21 ), 'glob - 1' );
+ok( $mysqpi->set( 'glob', \*STDOUT ), 'glob - 2' );
+is( $mysqpi->get('glob'), \*STDOUT, 'glob - 3' );
+ok( $mysqpi->set('glob'), 'glob - 4' );
+is( $mysqpi->get('glob'), undef, 'glob - 5' );
+
+# Test refs
+ok( !$mysqpi->set( 'ref', 21 ), 'ref - 1' );
+ok( $mysqpi->set( 'ref', \$rv ), 'ref - 2' );
+is( $mysqpi->get('ref'), \$rv, 'ref - 3' );
+ok( $mysqpi->set('ref'), 'ref - 4' );
+is( $mysqpi->get('ref'), undef, 'ref - 5' );
+
+# Test array
+my @array = qw(foo bar);
+my @rv;
+ok( $mysqpi->set( 'array', @array ), 'array - 1' );
+ at rv = $mysqpi->get('array');
+is( scalar @rv, 2, 'array - 2' );
+is( $rv[0], 'foo', 'array - 3' );
+ok( $mysqpi->set('array'), 'array - 4' );
+ at rv = $mysqpi->get('array');
+is( scalar @rv, 0, 'array - 5' );
+
+# Test hash
+my %hash = ( foo => 'one', bar => 'two' );
+my %rv;
+ok( $mysqpi->set( 'hash', %hash ), 'hash - 1' );
+%rv = $mysqpi->get('hash');
+is( scalar keys %rv, 2, 'hash - 2' );
+ok( exists $rv{foo}, 'hash - 3' );
+ok( $mysqpi->set('hash'), 'hash - 4' );
+%rv = $mysqpi->get('hash');
+is( scalar keys %rv, 0, 'hash - 5' );
+
+# Test properties
+my @props = $mysqpi->properties;
+is( scalar @props, 8, 'property names - 1' );
+ok( !grep({ $_ eq '2xpi' } @props), 'property names - 2' );
+ at props = $mysqpi->dump;
+is( scalar @props, 10, 'property names - 3' );
+ok( grep({ $_ eq '2xpi' } @props), 'property names - 4' );
+ok( !grep({ $_ eq '3xpi' } @props), 'property names - 5' );
+ at props = $mypi->dump;
+is( scalar @props, 3, 'property names - 6' );
+ok( grep({ $_ eq '2xpi' } @props), 'property names - 7' );
+ok( grep({ $_ eq '3xpi' } @props), 'property names - 8' );
diff --git a/t/06_methods.t b/t/06_methods.t
index 4392f8c..644cfe7 100644
--- a/t/06_methods.t
+++ b/t/06_methods.t
@@ -2,28 +2,22 @@
#
# Tests the method scoping
-use Test::More tests => 20;
+use Test::More tests => 21;
use strict;
use warnings;
package Foo;
-use vars qw(@ISA);
+use vars qw(@ISA @_methods);
use Class::EHierarchy qw(:all);
- at ISA = qw(Class::EHierarchy);
-
-sub _initialize ($@) {
- my $self = shift;
- my @args = @_;
-
- _declMethod( CEH_PRIV, qw(mpriv) );
- _declMethod( CEH_RESTR, qw(mrestr) );
- _declMethod( CEH_PUB, qw(mpub) );
-
- return 1;
-}
+ at ISA = qw(Class::EHierarchy);
+ at _methods = (
+ [ CEH_PRIV, qw(mpriv) ],
+ [ CEH_RESTR, qw(mrestr) ],
+ [ CEH_PUB, qw(mpub) ],
+ );
sub mpriv {
my $self = shift;
@@ -66,7 +60,7 @@ use Class::EHierarchy qw(:all);
@ISA = qw(Foo);
-sub _initialize ($@) {
+sub _initialize {
my $self = shift;
my @args = @_;
@@ -76,7 +70,7 @@ sub _initialize ($@) {
return 1;
}
-sub mpriv ($) {
+sub mpriv {
my $self = shift;
return 4;
@@ -133,18 +127,22 @@ ok( $class2a->isa('Foo'), 'Verify class Bar inheritance 2' );
# Private method tests
#
+# Private calls should fail
+ok( !$class1a->mpriv(), 'main calling Foo Private Method 1' );
+
# Call from same class should succeed
is( $class1a->callpriv($class1b), 2, 'Foo calling Foo Private Method 1' );
is( $class2a->callpriv($class2b), 4, 'Bar calling Bar Private Method 1' );
# Call from different class shoud fail
-$rv = eval '$class2a->callpriv($class1a); 1;';
-ok( !$rv, 'Bar calling Foo Private Method 1' );
-$rv = eval '$class1a->callpriv($class2a); 1;';
-ok( !$rv, 'Foo calling Bar Private Method 1' );
+ok( !$class2a->callpriv($class1a), 'Bar calling Foo Private Method 1' );
+ok( !$class1a->callpriv($class2a), 'Foo calling Bar Private Method 1' );
# Restricted method tests
#
+# Restricted calls should fail
+ok( !$class1a->mrestr(), 'main calling Foo Restricted Method 1' );
+
# Call from same class should succeed
is( $class1a->callrestr($class1b), 4, 'Foo calling Foo Restricted Method 1' );
is( $class2a->callrestr($class2b), 8, 'Bar calling Bar Restricted Method 1' );
@@ -153,10 +151,7 @@ is( $class2a->callrestr($class2b), 8, 'Bar calling Bar Restricted Method 1' );
is( $class2a->callrestr($class1a), 4, 'Bar calling Foo Restricted Method 1' );
# Call from non-subclass should fail
-$rv = eval '$class1a->callrestr($class2a); 1;';
-ok( !$rv, 'Foo calling Bar Restricted Method 1' );
-$rv = eval '$class1a->mrestr(); 1;';
-ok( !$rv, 'Main calling Foo Restricted Method 1' );
+ok( !$class1a->callrestr($class2a), 'Foo calling Bar Restricted Method 1' );
# Public method tests
#
@@ -164,4 +159,3 @@ ok( !$rv, 'Main calling Foo Restricted Method 1' );
is( $class1a->mpub, 8, 'Foo Public Method 1' );
is( $class2a->mpub, 16, 'Bar Public Method 1' );
-# end 06_methods.t
diff --git a/t/07_loadProps.t b/t/07_loadProps.t
deleted file mode 100644
index 51068ec..0000000
--- a/t/07_loadProps.t
+++ /dev/null
@@ -1,364 +0,0 @@
-# 07_loadProps.t
-#
-# Tests the various property types and scoping
-
-use Test::More tests => 92;
-
-use strict;
-use warnings;
-
-package Foo;
-
-use vars qw(@ISA @_properties);
-use Class::EHierarchy qw(:all);
-
- at ISA = qw(Class::EHierarchy);
- at _properties = (
- [ CEH_PRIV | CEH_SCALAR, 'PrivFoo', 'foo!' ],
- [ CEH_PRIV | CEH_ARRAY, 'PrivFooArray', [ qw(f1 f2 f3) ] ],
- [ CEH_PRIV | CEH_HASH, 'PrivFooHash', {
- f1 => 'one',
- f2 => 'two',
- f3 => 'three' } ],
- [ CEH_RESTR | CEH_SCALAR, 'RestrFoo', 'rfoo!' ],
- [ CEH_RESTR | CEH_ARRAY, 'RestrFooArray', [ qw(f11 f12 f13) ] ],
- [ CEH_PUB | CEH_SCALAR, 'PubFoo', 'pfoo!' ]
- );
-
-sub _initialize ($@) {
- my $self = shift;
- my @args = @_;
-
- return 1;
-}
-
-sub call ($$$) {
- my $self = shift;
- my $obj = shift;
- my $prop = shift;
-
- return $obj->property( $prop, @_ );
-}
-
-sub cpurge ($$) {
- my $self = shift;
- my $prop = shift;
-
- return $self->purge($prop);
-}
-
-1;
-
-package Bar;
-
-use vars qw(@ISA @_properties);
-use Class::EHierarchy qw(:all);
-
- at ISA = qw(Class::EHierarchy);
-
- at _properties = (
- [ CEH_PRIV | CEH_SCALAR, 'PrivBar', 'bar!' ],
- [ CEH_PRIV | CEH_ARRAY, 'PrivBarArray', [ qw(b1 b2 b3 b4) ] ],
- [ CEH_PRIV | CEH_HASH, 'PrivBarHash', {
- b1 => 'one',
- b2 => 'two',
- b3 => 'three',
- } ],
- [ CEH_RESTR | CEH_SCALAR, 'RestrBar', 'rbar!' ],
- [ CEH_RESTR | CEH_ARRAY, 'RestrBarArray', [ qw(b11 b12 b13 b14) ] ],
- [ CEH_RESTR | CEH_HASH, 'RestrBarHash', {
- b11 => 'one',
- b12 => 'two',
- b13 => 'three'
- } ],
- [ CEH_PUB | CEH_CODE, 'PubBar', 'pbar!' ]
- );
-
-sub _initialize ($@) {
- my $self = shift;
- my @args = @_;
-
- return 1;
-}
-
-sub call ($$$) {
- my $self = shift;
- my $obj = shift;
- my $prop = shift;
-
- return $obj->property( $prop, @_ );
-}
-
-sub callNames ($$) {
- my $self = shift;
- my $obj = shift;
-
- return $obj->propertyNames;
-}
-
-sub cpurge ($$) {
- my $self = shift;
- my $prop = shift;
-
- return $self->purge($prop);
-}
-
-1;
-
-package Roo;
-
-use vars qw(@ISA @_properties);
-use Class::EHierarchy qw(:all);
-
- at ISA = qw(Bar);
- at _properties = (
- [ CEH_PRIV | CEH_SCALAR, 'PrivRoo', 'roo!' ],
- [ CEH_PRIV | CEH_SCALAR, 'PrivBar', 'roo-bar!' ],
- [ CEH_PRIV | CEH_ARRAY, 'PrivBarArray', [ qw(r1) ] ],
- [ CEH_RESTR | CEH_HASH, 'RestrRooHash', {
- r11 => 'one',
- r12 => 'two',
- r13 => 'three',
- } ],
- [ CEH_PUB | CEH_ARRAY, 'PubArray' ],
- [ CEH_PUB | CEH_HASH, 'PubHash' ],
- [ CEH_PUB | CEH_REF | CEH_NO_UNDEF, 'PubRef' ]
- );
-
-sub call ($$$) {
- my $self = shift;
- my $obj = shift;
- my $prop = shift;
-
- return $obj->property( $prop, @_ );
-}
-
-sub callNames ($$) {
- my $self = shift;
- my $obj = shift;
-
- return $obj->propertyNames;
-}
-
-sub cpurge ($$) {
- my $self = shift;
- my $prop = shift;
-
- return $self->purge($prop);
-}
-
-1;
-
-package main;
-
-my $class1a = new Foo;
-my $class1b = new Foo;
-my $class2a = new Bar;
-my $class2b = new Bar;
-my $class3a = new Roo;
-my $class3b = new Roo;
-
-my $rv;
-
-# Test subclass instantiation
-ok( defined $class1a, 'Created object for class Foo 1' );
-ok( defined $class1b, 'Created object for class Foo 2' );
-ok( $class1a->isa('Foo'), 'Verify class Foo 1' );
-ok( $class1a->isa('Class::EHierarchy'), 'Verify class Foo inheritance 1' );
-
-ok( defined $class2a, 'Created object for class Bar 1' );
-ok( defined $class2b, 'Created object for class Bar 2' );
-ok( $class2a->isa('Bar'), 'Verify class Bar 1' );
-ok( $class2a->isa('Class::EHierarchy'), 'Verify class Bar inheritance 1' );
-
-ok( defined $class3a, 'Created object for class Roo 1' );
-ok( defined $class3b, 'Created object for class Roo 2' );
-ok( $class3a->isa('Roo'), 'Verify class Roo 1' );
-ok( $class3a->isa('Class::EHierarchy'), 'Verify class Roo inheritance 1' );
-ok( $class3a->isa('Bar'), 'Verify class Roo inheritance 2' );
-
-# Set extra copies of objects to different property values
-ok( $class1b->call( $class1b, qw(PrivFoo nope!) ), 'Foo prep 1' );
-is( $class1b->call( $class1b, qw(PrivFoo) ), 'nope!', 'Foo prep validate 1' );
-ok( $class1b->call( $class1b, qw(RestrFoo nope) ), 'Foo prep 2' );
-is( $class1b->call( $class1b, qw(RestrFoo) ), 'nope', 'Foo prep validate 2' );
-ok( $class2b->call( $class2b, qw(PrivBar nope!) ), 'Bar prep 1' );
-is( $class2b->call( $class2b, qw(PrivBar) ), 'nope!', 'Bar prep validate 1' );
-ok( $class2b->call( $class2b, qw(RestrBar nope) ), 'Bar prep 2' );
-is( $class2b->call( $class2b, qw(RestrBar) ), 'nope', 'Bar prep validate 2' );
-ok( $class3b->call( $class3b, qw(PrivRoo nope!) ), 'Roo prep 1' );
-is( $class3b->call( $class3b, qw(PrivRoo) ), 'nope!', 'Roo prep validate 1' );
-ok( $class3b->call( $class3b, qw(PrivBar nope!) ), 'Roo prep 2' );
-is( $class3b->call( $class3b, qw(PrivBar) ), 'nope!', 'Roo prep validate 2' );
-
-# Scalar Private Property tests
-#
-# Call from same class should succeed
-is( $class1b->call( $class1a, qw(PrivFoo) ) , 'foo!',
- 'Foo Private Scalar Property Get 1' );
-is( $class2b->call( $class2a, qw(PrivBar) ) , 'bar!',
- 'Bar Private Scalar Property Get 1' );
-is( $class3b->call( $class3a, qw(PrivRoo) ) , 'roo!',
- 'Roo Private Scalar Property Get 1' );
-
-# Call from different class shoud fail
-$rv = eval '$class2a->call($class1a, qw(PrivFoo)); 1;';
-ok( !$rv, 'Bar calling Foo Private Scalar 1' );
-$rv = eval '$class1a->call($class2a, qw(PrivBar)); 1;';
-ok( !$rv, 'Foo calling Bar Private Scalar 1' );
-$rv = eval '$class3a->call($class2a, qw(PrivBar)); 1;';
-ok( !$rv, 'Roo calling Bar Private Scalar 1' );
-
-# Check class protection of private name collisions
-is( $class2b->call( $class3a, qw(PrivBar)), 'bar!', 'Class Collision 1' );
-is( $class3b->call( $class3a, qw(PrivBar)), 'roo-bar!', 'Class Collision 2' );
-ok( $class3b->call( $class3a, qw(PrivBar nrp-bar!) ), 'Class Collision 3' );
-ok( $class2b->call( $class3a, qw(PrivBar nbp-bar!) ), 'Class Collision 4' );
-is( $class2b->call( $class3a, qw(PrivBar)), 'nbp-bar!', 'Class Collision 5' );
-is( $class3b->call( $class3a, qw(PrivBar)), 'nrp-bar!', 'Class Collision 6' );
-
-# Scalar Restricted Property tests
-#
-# Calls from same class should succeed
-is( $class1b->call( $class1a, qw(RestrFoo) ) , 'rfoo!',
- 'Foo Restricted Scalar Property Get 1' );
-is( $class2b->call( $class2a, qw(RestrBar) ) , 'rbar!',
- 'Bar Restricted Scalar Property Get 1' );
-
-# Calls from subclasses should succeed
-is( $class3b->call( $class2a, qw(RestrBar) ) , 'rbar!',
- 'Bar Restricted Property Get 2' );
-is( $class3b->call( $class3a, qw(RestrBar) ) , 'rbar!',
- 'Bar Restricted Property Get 3' );
-
-# Calls from elsewhere should fail
-$rv = eval '$class1a->call($class2a, qw(RestrBar)); 1;';
-ok( !$rv, 'Foo calling Bar Restricted Scalar 1' );
-$rv = eval '$class2a->property(qw(RestrBar)); 1;';
-ok( !$rv, 'Main calling Bar Restricted Scalar 1' );
-
-# Set extra copies of objects to different property values
-ok( $class1b->cpurge( qw(PrivFooArray)), 'Foo prep 3' );
-$rv = [ $class1b->call( $class1b, qw(PrivFooArray)) ];
-is( scalar @$rv, 0, 'Foo prep validate 3' );
-ok( $class2b->cpurge( qw(PrivBarArray)), 'Bar prep 3' );
-$rv = [ $class2b->call( $class2b, qw(PrivBarArray)) ];
-is( scalar @$rv, 0, 'Bar prep validate 3' );
-ok( $class3b->cpurge( qw(PrivBarArray)), 'Roo prep 3' );
-$rv = [ $class3b->call( $class3b, qw(PrivBarArray)) ];
-is( scalar @$rv, 0, 'Roo prep validate 3' );
-
-# Array Private Property tests
-#
-# Call from same class should succeed
-$rv = [ $class1b->call( $class1a, qw(PrivFooArray)) ];
-is( scalar @$rv, 3, 'Foo Private Array Property Get 1' );
-is( $$rv[1], 'f2', 'Foo Private Array Property Get 2' );
-$rv = [ $class2b->call( $class2a, qw(PrivBarArray)) ];
-is( scalar @$rv, 4, 'Bar Private Array Property Get 1' );
-is( $$rv[1], 'b2', 'Bar Private Array Property Get 2' );
-$rv = [ $class3b->call( $class3a, qw(PrivBarArray)) ];
-is( scalar @$rv, 1, 'Roo Private Array Property Get 1' );
-is( $$rv[0], 'r1', 'Roo Private Array Property Get 2' );
-
-# Call from different class shoud fail
-$rv = eval '$class2a->call($class1a, qw(PrivFooArray)); 1;';
-ok( !$rv, 'Bar calling Foo Private Array 1' );
-$rv = eval '$class1a->call($class2a, qw(PrivBarArray)); 1;';
-ok( !$rv, 'Foo calling Bar Private Array 1' );
-$rv = eval '$class3a->call($class2a, qw(PrivBarArray)); 1;';
-ok( !$rv, 'Roo calling Bar Private Array 1' );
-
-# Array Restricted Property tests
-#
-# Calls from same class should succeed
-$rv = [ $class1b->call( $class1a, qw(RestrFooArray)) ];
-is( scalar @$rv, 3, 'Foo Restricted Array Property Get 1' );
-is( $$rv[1], 'f12', 'Foo Restricted Array Property Get 2' );
-$rv = [ $class2b->call( $class2a, qw(RestrBarArray)) ];
-is( scalar @$rv, 4, 'Bar Restricted Array Property Get 1' );
-is( $$rv[1], 'b12', 'Bar Restricted Array Property Get 2' );
-
-# Calls from subclasses should succeed
-$rv = [ $class3b->call( $class2a, qw(RestrBarArray)) ];
-is( scalar @$rv, 4, 'Bar from Roo Restricted Array Property Get 1' );
-is( $$rv[1], 'b12', 'Bar from Roo Restricted Array Property Get 2' );
-
-# Calls from elsewhere should fail
-$rv = eval '$class1b->call( $class2a, qw(RestrBarArray)); 1;';
-ok( !$rv, 'Foo calling Bar Restricted Array 1' );
-$rv = eval '$class3a->property(qw(RestrBarArray)); 1;';
-ok( !$rv, 'Main calling Roo Restricted Array 1' );
-
-# Set extra copies of objects to different property values
-ok( $class1b->cpurge( qw(PrivFooHash)), 'Foo prep 4' );
-$rv = [ $class1b->call( $class1b, qw(PrivFooHash)) ];
-is( scalar @$rv, 0, 'Foo prep validate 4' );
-ok( $class2b->cpurge( qw(PrivBarHash)), 'Bar prep 4' );
-$rv = [ $class2b->call( $class2b, qw(PrivBarHash)) ];
-is( scalar @$rv, 0, 'Bar prep validate 4' );
-
-# Hash Private Property tests
-#
-# Calls from same class should succeed
-$rv = { $class1b->call( $class1a, qw(PrivFooHash)) };
-is( $$rv{f1}, 'one', 'Foo Private Hash Property Get 1' );
-$rv = { $class2b->call( $class2a, qw(PrivBarHash)) };
-is( $$rv{b3}, 'three', 'Bar Private Hash Property Get 1' );
-
-# Call from different class shoud fail
-$rv = eval '$class2a->call($class1a, qw(PrivFooHash)); 1;';
-ok( !$rv, 'Bar calling Foo Private Hash 1' );
-$rv = eval '$class3a->call($class2a, qw(PrivBarHash)); 1;';
-ok( !$rv, 'Roo calling Bar Private Hash 1' );
-
-# Hash Restricted Property tests
-#
-# Calls from same class should succeed
-$rv = { $class3b->call( $class2a, qw(RestrBarHash)) };
-is( $$rv{b12}, 'two', 'Bar Restricted Hash Property Get 1' );
-
-# Calls from elsewhere should fail
-$rv = eval '$class1b->call( $class2a, qw(RestrBarHash)); 1;';
-ok( !$rv, 'Foo calling Bar Restricted Hash 1' );
-$rv = eval '$class2b->call( $class3a, qw(RestrRooHash)); 1;';
-ok( !$rv, 'Bar calling Roo Restricted Hash 1' );
-
-# Public array tests
-$rv = [ $class3a->property('PubArray') ];
-is( scalar @$rv, 0, 'Public Array Get 1' );
-$rv = $class3a->property( 'PubArray', qw(three two one) );
-ok( $rv, 'Public Array Set 1' );
-$rv = [ $class3a->property('PubArray') ];
-is( $$rv[0], 'three', 'Public Array Get 2' );
-
-# Public hash tests
-$rv = { $class3a->property('PubHash') };
-is( scalar keys %$rv, 0, 'Public Hash Get 1' );
-$rv = $class3a->property( 'PubHash', foo => 'bar' );
-ok( $rv, 'Public Hash Set 1' );
-$rv = { $class3a->property('PubHash') };
-is( scalar keys %$rv, 1, 'Public Hash Get 2' );
-is( $$rv{foo}, 'bar', 'Public Hash Get 3' );
-
-# Public ref tests
-$rv = $class3a->property('PubRef');
-is( $rv, undef, 'Public Ref Get 1' );
-$rv = $class3a->property( 'PubRef', qr/foo/ );
-ok( $rv, 'Public Ref Set 1' );
-$rv = $class3a->property('PubRef');
-is( $rv, qr/foo/, 'Public Ref Get 2' );
-$rv = $class3a->property( 'PubRef', undef );
-ok( !$rv, 'Public Ref Set 2' );
-$rv = $class3a->property('PubRef');
-is( $rv, qr/foo/, 'Public Ref Get 3' );
-
-# Test propertyNames
-my @names = $class1a->propertyNames;
-is( scalar @names, 1, 'Public Property Names 1' );
- at names = $class3b->callNames($class2a);
-is( scalar @names, 4, 'Restricted Property Names 1' );
- at names = $class2b->callNames($class2a);
-is( scalar @names, 7, 'Private Property Names 1' );
-
-# end 07_loadProps.t
diff --git a/t/07_type_methods.t b/t/07_type_methods.t
new file mode 100644
index 0000000..4bb09bc
--- /dev/null
+++ b/t/07_type_methods.t
@@ -0,0 +1,99 @@
+# 07_type_methods.t
+#
+# Tests the data type aware property methods
+
+use Test::More tests => 42;
+
+use strict;
+use warnings;
+
+package MyClass;
+
+use vars qw(@ISA @_properties);
+use Class::EHierarchy qw(:all);
+
+ at ISA = qw(Class::EHierarchy);
+
+ at _properties = (
+ [ CEH_PUB | CEH_ARRAY, 'array', [qw(foo bar)] ],
+ [ CEH_PUB | CEH_HASH, 'hash', {qw(foo bar)} ],
+ );
+
+1;
+
+package main;
+
+my $obj = new MyClass;
+my ( $rv, @rv, %rv );
+
+# Create our objects
+ok( defined $obj, 'class object instantiation - 1' );
+
+# Check initialized values
+ at rv = $obj->get('array');
+%rv = $obj->get('hash');
+
+is( scalar @rv, 2, 'array initialization - 1' );
+is( $rv[0], 'foo', 'array initialization - 2' );
+is( scalar keys %rv, 1, 'hash initialization - 1' );
+is( $rv{foo}, 'bar', 'hash initialization - 2' );
+
+# Test array methods
+is( $obj->push('array'), 2, 'push - 1' );
+is( $obj->push(qw(array roo)), 3, 'push - 2' );
+is( $obj->push(qw(array x y)), 5, 'push - 3' );
+is( $obj->pop('array'), 'y', 'pop - 1' );
+is( $obj->unshift('array'), 4, 'unshift - 1' );
+is( $obj->unshift(qw(array i)), 5, 'unshift - 2' );
+is( $obj->unshift(qw(array j k)), 7, 'unshift - 3' );
+is( $obj->shift('array'), 'j', 'unshift - 4' );
+
+# Test hash methods
+ok( $obj->exists(qw(hash foo)), 'exists - 1' );
+ok( !$obj->exists(qw(hash bar)), 'exists - 2' );
+ at rv = $obj->keys('hash');
+is( scalar @rv, 1, 'keys - 1' );
+is( $rv[0], 'foo', 'keys - 2' );
+
+# Test unified methods
+#
+# Test merge
+ok( $obj->merge(qw(array 1 a 3 b 5 c)), 'array merge - 1' );
+ at rv = $obj->get('array');
+is( $rv[0], 'k', 'array merge - 2' );
+is( $rv[1], 'a', 'array merge - 3' );
+is( $rv[3], 'b', 'array merge - 4' );
+is( $rv[5], 'c', 'array merge - 5' );
+ok( $obj->merge(qw(hash x y j k)), 'hash merge - 1' );
+%rv = $obj->get('hash');
+is( $rv{foo}, 'bar', 'hash merge - 2' );
+is( $rv{x}, 'y', 'hash merge - 2' );
+is( $rv{j}, 'k', 'hash merge - 2' );
+
+# Test subset
+ at rv = $obj->subset(qw(array 0 1 3 5));
+is( scalar @rv, 4, 'array subset - 1' );
+is( $rv[0], 'k', 'array subset - 2' );
+is( $rv[3], 'c', 'array subset - 3' );
+ at rv = $obj->subset(qw(hash foo x));
+is( scalar @rv, 2, 'hash subset - 1' );
+is( $rv[0], 'bar', 'hash subset - 2' );
+is( $rv[1], 'y', 'hash subset - 3' );
+
+# Test remove
+ok( $obj->remove(qw(array 1 3 5)), 'array remove - 1' );
+ at rv = $obj->get('array');
+is( $rv[1], 'foo', 'array remove - 2' );
+is( $rv[2], 'roo', 'array remove - 3' );
+ok( $obj->remove(qw(hash foo x)), 'hash remove - 1' );
+%rv = $obj->get('hash');
+is( $rv{j}, 'k', 'hash remove - 2' );
+ok( !exists $rv{x}, 'hash remove - 3' );
+
+# Test empty
+ok( $obj->empty('array'), 'array empty - 1' );
+ at rv = $obj->get('array');
+is( scalar @rv, 0, 'array empty - 2' );
+ok( $obj->empty('hash'), 'hash empty - 1' );
+%rv = $obj->get('hash');
+is( scalar keys %rv, 0, 'hash empty - 2' );
diff --git a/t/08_loadMethods.t b/t/08_loadMethods.t
deleted file mode 100644
index c38c13b..0000000
--- a/t/08_loadMethods.t
+++ /dev/null
@@ -1,170 +0,0 @@
-# 08_loadMethods.t
-#
-# Tests the method scoping
-
-use Test::More tests => 20;
-
-use strict;
-use warnings;
-
-package Foo;
-
-use vars qw(@ISA @_methods);
-use Class::EHierarchy qw(:all);
-
- at ISA = qw(Class::EHierarchy);
- at _methods = (
- [ CEH_PRIV, qw(mpriv) ],
- [ CEH_RESTR, qw(mrestr) ],
- [ CEH_PUB, qw(mpub) ],
- );
-
-sub _initialize ($@) {
- my $self = shift;
- my @args = @_;
-
- return 1;
-}
-
-sub mpriv {
- my $self = shift;
-
- return 2;
-}
-
-sub mrestr {
- my $self = shift;
-
- return 4;
-}
-
-sub mpub {
- my $self = shift;
-
- return 8;
-}
-
-sub callpriv {
- my $self = shift;
- my $obj = shift;
-
- return $obj->mpriv;
-}
-
-sub callrestr {
- my $self = shift;
- my $obj = shift;
-
- return $obj->mrestr;
-}
-
-1;
-
-package Bar;
-
-use vars qw(@ISA @_methods);
-use Class::EHierarchy qw(:all);
-
- at ISA = qw(Foo);
- at _methods = (
- [ CEH_PRIV, qw(mpriv) ],
- [ CEH_RESTR, qw(mrestr) ],
- [ CEH_PUB, qw(mpub) ]
- );
-
-sub _initialize ($@) {
- my $self = shift;
- my @args = @_;
-
- return 1;
-}
-
-sub mpriv ($) {
- my $self = shift;
-
- return 4;
-}
-
-sub mrestr {
- my $self = shift;
-
- return 8;
-}
-
-sub mpub {
- my $self = shift;
-
- return 16;
-}
-
-sub callpriv {
- my $self = shift;
- my $obj = shift;
-
- return $obj->mpriv;
-}
-
-sub callrestr {
- my $self = shift;
- my $obj = shift;
-
- return $obj->mrestr;
-}
-
-1;
-
-package main;
-
-my $class1a = new Foo;
-my $class1b = new Foo;
-my $class2a = new Bar;
-my $class2b = new Bar;
-
-my $rv;
-
-# Test subclass instantiation
-ok( defined $class1a, 'Created object for class Foo 1' );
-ok( defined $class1b, 'Created object for class Foo 2' );
-ok( $class1a->isa('Foo'), 'Verify class Foo 1' );
-ok( $class1a->isa('Class::EHierarchy'), 'Verify class Foo inheritance 1' );
-
-ok( defined $class2a, 'Created object for class Bar 1' );
-ok( defined $class2b, 'Created object for class Bar 2' );
-ok( $class2a->isa('Bar'), 'Verify class Bar 1' );
-ok( $class2a->isa('Class::EHierarchy'), 'Verify class Bar inheritance 1' );
-ok( $class2a->isa('Foo'), 'Verify class Bar inheritance 2' );
-
-# Private method tests
-#
-# Call from same class should succeed
-is( $class1a->callpriv($class1b), 2, 'Foo calling Foo Private Method 1' );
-is( $class2a->callpriv($class2b), 4, 'Bar calling Bar Private Method 1' );
-
-# Call from different class shoud fail
-$rv = eval '$class2a->callpriv($class1a); 1;';
-ok( !$rv, 'Bar calling Foo Private Method 1' );
-$rv = eval '$class1a->callpriv($class2a); 1;';
-ok( !$rv, 'Foo calling Bar Private Method 1' );
-
-# Restricted method tests
-#
-# Call from same class should succeed
-is( $class1a->callrestr($class1b), 4, 'Foo calling Foo Restricted Method 1' );
-is( $class2a->callrestr($class2b), 8, 'Bar calling Bar Restricted Method 1' );
-
-# Call from subclass should succeed
-is( $class2a->callrestr($class1a), 4, 'Bar calling Foo Restricted Method 1' );
-
-# Call from non-subclass should fail
-$rv = eval '$class1a->callrestr($class2a); 1;';
-ok( !$rv, 'Foo calling Bar Restricted Method 1' );
-$rv = eval '$class1a->mrestr(); 1;';
-ok( !$rv, 'Main calling Foo Restricted Method 1' );
-
-# Public method tests
-#
-# Calls should succeed
-is( $class1a->mpub, 8, 'Foo Public Method 1' );
-is( $class2a->mpub, 16, 'Bar Public Method 1' );
-
-# end 08_loadMethods.t
diff --git a/t/09_aliases.t b/t/09_aliases.t
deleted file mode 100644
index fcb73f5..0000000
--- a/t/09_aliases.t
+++ /dev/null
@@ -1,72 +0,0 @@
-# 09_aliases.t
-#
-# Tests the tracking of object relationships
-
-use Test::More tests => 28;
-
-use strict;
-use warnings;
-
-use Class::EHierarchy;
-
-my $obj1 = new Class::EHierarchy;
-my $obj2 = new Class::EHierarchy;
-my $obj3 = new Class::EHierarchy;
-my $obj4 = new Class::EHierarchy;
-
-# Aliases should all be the same at this time
-ok( $obj1->alias eq 'Class::EHierarchy0', 'Default Alias 1' );
-ok( $obj2->alias eq 'Class::EHierarchy0', 'Default Alias 2' );
-ok( $obj3->alias eq 'Class::EHierarchy0', 'Default Alias 3' );
-ok( $obj4->alias eq 'Class::EHierarchy0', 'Default Alias 4' );
-
-# Test alias rename
-ok( $obj1->alias('root'), 'Set Alias 1');
-ok( $obj1->alias eq 'root', 'Check Set Alias 1');
-
-# Start merging aliases
-$obj1->adopt($obj2, $obj3);
-$obj3->adopt($obj4);
-ok( $obj1->alias eq 'root', 'Merge Alias 1');
-ok( $obj2->alias eq 'Class::EHierarchy0', 'Merge Alias 2' );
-ok( $obj3->alias eq 'Class::EHierarchy1', 'Merge Alias 3' );
-ok( $obj4->alias eq 'Class::EHierarchy2', 'Merge Alias 4' );
-
-# Test more alias renames
-ok( $obj2->alias('joe'), 'Set Alias 2');
-ok( $obj2->alias eq 'joe', 'Check Set Alias 2');
-ok( $obj3->alias('fred'), 'Set Alias 3');
-ok( $obj3->alias eq 'fred', 'Check Set Alias 3');
-
-# Test Relative retrieval
-ok( $obj2->relative('root') == $obj1, 'Relative 1');
-ok( $obj3->relative('root') == $obj1, 'Relative 2');
-ok( $obj4->relative('root') == $obj1, 'Relative 3');
-ok( $obj4->relative('joe') == $obj2, 'Relative 4');
-ok( $obj4->relative('fred') == $obj3, 'Relative 5');
-
-# Test relatives
-my @objects = $obj1->relatives('Class');
-ok( scalar @objects == 1, 'Relatives 1');
-ok( $objects[0] == $obj4, 'Relatives 2');
-
-# Test split
-$obj1->disown($obj3);
-ok( ! defined $obj1->relative('fred'), 'Split Alias 1');
-ok( defined $obj3->relative('fred'), 'Split Alias 2');
-ok( ! defined $obj3->relative('root'), 'Split Alias 3');
-ok( defined $obj1->relative('root'), 'Split Alias 4');
-
-# Test Merge
-my $obj5 = new Class::EHierarchy;
-my $obj6 = new Class::EHierarchy;
-my $obj7 = new Class::EHierarchy;
-$obj1->adopt($obj5);
-$obj3->adopt($obj6);
-$obj4->adopt($obj7);
-$obj1->adopt($obj3);
-ok( $obj5->alias eq 'Class::EHierarchy0', 'Merge Alias 5');
-ok( $obj1->relative('fred') == $obj3, 'Merge Alias 6');
-ok( $obj3->relative('joe') == $obj2, 'Merge Alias 7');
-
-# end 09_aliases.t
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libclass-ehierarchy-perl.git
More information about the Pkg-perl-cvs-commits
mailing list