Tree-Simple-1.29/0000755000175000017500000000000012712222050011742 5ustar ronronTree-Simple-1.29/MANIFEST.SKIP0000644000175000017500000000114012707602364013652 0ustar ronron# Avoid version control files. ,v$ \B\.cvsignore$ \B\.git\b \B\.gitignore\b \B\.svn\b \bCVS\b \bRCS\b # Avoid Makemaker generated and utility files. \bblib \bblibdirs$ \bpm_to_blib$ \bMakefile$ \bMakeMaker-\d # Avoid Module::Build generated and utility files. \b_build \bBuild$ \bBuild.bat$ # Avoid Devel::Cover generated files \bcover_db # Avoid temp and backup files. ~$ \#$ \.# \.bak$ \.old$ \.rej$ \.tmp$ # Avoid OS-specific files/dirs # Mac OSX metadata \B\.DS_Store # Mac OSX SMB mount metadata files \B\._ # Avoid UltraEdit files. \.prj$ \.pui$ ^MYMETA.yml$ ^MYMETA\.json$ ^Tree-Simple-.* Tree-Simple-1.29/README0000644000175000017500000000244112707256226012643 0ustar ronronTree-Simple is Copyright (C) 2004-2006 by Infinity Interactive, Inc. LICENSE INFORMATION This library is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10.0. For more details, see the full text of the licenses at http://www.perlfoundation.org/artistic_license_1_0, and http://www.gnu.org/licenses/gpl-2.0.html. See also CHANGES and Changelog.ini. Warning: WinZip 8.1 and 9.0 both contain an 'accidental' bug which stops them recognizing POSIX-style directory structures in valid tar files. You are better off using a reliable tool such as InfoZip: ftp://ftp.info-zip.org/pub/infozip/ 1 Installing from a Unix-like distro ------------------------------------ shell>gunzip Tree-Simple-1.23.tgz shell>tar mxvf Tree-Simple-1.23.tar Note: 'make' on MS Windows-like systems may be called 'nmake' or 'dmake'. shell>perl Makefile.PL shell>make shell>make test shell>su (for Unix-like systems) shell>make install shell>exit (for Unix-like systems) On all systems: Run Simple.pm through your favourite pod2html translator. 2 Installing from an ActiveState distro --------------------------------------- shell>unzip Tree-Simple-1.23.zip shell>ppm install --location=. Tree-Simple shell>del Tree-Simple-1.23.ppd shell>del PPM-Tree-Simple-1.23.tar.gz Tree-Simple-1.29/META.json0000644000175000017500000000301212712222050013357 0ustar ronron{ "abstract" : "A simple tree object", "author" : [ "Stevan Little " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.14, CPAN::Meta::Converter version 2.150005", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Tree-Simple", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Scalar::Util" : "1.18", "constant" : "0", "strict" : "0", "warnings" : "0" } }, "test" : { "requires" : { "Test::Exception" : "0.15", "Test::More" : "1.001014" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Tree-Simple" }, "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "type" : "git", "url" : "https://github.com/ronsavage/Tree-Simple.git", "web" : "https://github.com/ronsavage/Tree-Simple" } }, "version" : "1.29", "x_serialization_backend" : "JSON::PP version 2.27203" } Tree-Simple-1.29/Makefile.PL0000644000175000017500000000236112707572203013732 0ustar ronronuse 5.006; use strict; use warnings; use ExtUtils::MakeMaker; # ---------------- my(%params) = ( ($] ge '5.005') ? ( AUTHOR => 'Stevan Little ', ABSTRACT => 'A simple tree object', ) : (), clean => { FILES => 'blib/* Makefile Tree-Simple-*' }, dist => { COMPRESS => 'gzip', SUFFIX => 'gz' }, DISTNAME => 'Tree-Simple', NAME => 'Tree::Simple', PL_FILES => {}, PREREQ_PM => { 'constant' => 0, 'Scalar::Util' => '1.18', 'strict' => 0, 'warnings' => 0, }, TEST_REQUIRES => { 'Test::Exception' => '0.15', 'Test::More' => 1.001014, }, VERSION_FROM => 'lib/Tree/Simple.pm', ); if ( ($ExtUtils::MakeMaker::VERSION =~ /^\d\.\d\d$/) && ($ExtUtils::MakeMaker::VERSION > 6.30) ) { $params{LICENSE} = 'perl'; } if ($ExtUtils::MakeMaker::VERSION ge '6.46') { $params{META_MERGE} = { 'meta-spec' => { version => 2, }, resources => { bugtracker => { web => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Tree-Simple', }, license => 'http://dev.perl.org/licenses/', repository => { type => 'git', url => 'https://github.com/ronsavage/Tree-Simple.git', web => 'https://github.com/ronsavage/Tree-Simple', }, }, }; } WriteMakefile(%params); Tree-Simple-1.29/lib/0000755000175000017500000000000012712222050012510 5ustar ronronTree-Simple-1.29/lib/Tree/0000755000175000017500000000000012712222050013407 5ustar ronronTree-Simple-1.29/lib/Tree/Simple/0000755000175000017500000000000012712222050014640 5ustar ronronTree-Simple-1.29/lib/Tree/Simple/Visitor.pm0000644000175000017500000002321712712222047016650 0ustar ronronpackage Tree::Simple::Visitor; use strict; use warnings; our $VERSION = '1.29'; use Scalar::Util qw(blessed); ## class constants use constant RECURSIVE => 0x01; use constant CHILDREN_ONLY => 0x10; ### constructor sub new { my ($_class, $func, $depth) = @_; if (defined($depth)){ ($depth =~ /\d+/ && ($depth == RECURSIVE || $depth == CHILDREN_ONLY)) || die "Insufficient Arguments : Depth arguement must be either ". "RECURSIVE or CHILDREN_ONLY"; } my $class = ref($_class) || $_class; # if we have not supplied a $func # it is automatically RECURSIVE $depth = RECURSIVE unless defined $func; my $visitor = { depth => $depth || 0 }; bless($visitor, $class); $visitor->_init(); if (defined $func) { $visitor->setNodeFilter($func); $visitor->includeTrunk(1); } return $visitor; } ### methods sub _init { my ($self) = @_; $self->{_include_trunk} = 0; $self->{_filter_function} = undef; $self->{_results} = []; } sub includeTrunk { my ($self, $boolean) = @_; $self->{_include_trunk} = ($boolean ? 1 : 0) if defined $boolean; return $self->{_include_trunk}; } # node filter methods sub getNodeFilter { my ($self) = @_; return $self->{_filter_function}; } sub clearNodeFilter { my ($self) = @_; $self->{_filter_function} = undef; } sub setNodeFilter { my ($self, $filter_function) = @_; (defined($filter_function) && ref($filter_function) eq "CODE") || die "Insufficient Arguments : filter function argument must be a subroutine reference"; $self->{_filter_function} = $filter_function; } # results methods sub setResults { my ($self, @results) = @_; $self->{results} = \@results; } sub getResults { my ($self) = @_; return wantarray ? @{$self->{results}} : $self->{results}; } # visit routine sub visit { my ($self, $tree) = @_; (blessed($tree) && $tree->isa("Tree::Simple")) || die "Insufficient Arguments : You must supply a valid Tree::Simple object"; # get all things set up my @results; my $func; if ($self->{_filter_function}) { $func = sub { push @results => $self->{_filter_function}->(@_) }; } else { $func = sub { push @results => $_[0]->getNodeValue() }; } # always apply the function # to the tree's node $func->($tree) if (defined($self->{_include_trunk}) && $self->{_include_trunk}); # then recursively to all its children # if the object is configured that way $tree->traverse($func) if ($self->{depth} == RECURSIVE); # or just visit its immediate children # if the object is configured that way if ($self->{depth} == CHILDREN_ONLY) { $func->($_) foreach $tree->getAllChildren(); } # now store the results we got $self->setResults(@results); } 1; __END__ =head1 NAME Tree::Simple::Visitor - Visitor object for Tree::Simple objects =head1 SYNOPSIS use Tree::Simple; use Tree::Simple::Visitor; # create a visitor instance my $visitor = Tree::Simple::Visitor->new(); # create a tree to visit my $tree = Tree::Simple->new(Tree::Simple->ROOT) ->addChildren( Tree::Simple->new("1.0"), Tree::Simple->new("2.0") ->addChild( Tree::Simple->new("2.1.0") ), Tree::Simple->new("3.0") ); # by default this will collect all the # node values in depth-first order into # our results $tree->accept($visitor); # get our results and print them print join ", ", $visitor->getResults(); # prints "1.0, 2.0, 2.1.0, 3.0" # for more complex node objects, you can specify # a node filter which will be used to extract the # information desired from each node $visitor->setNodeFilter(sub { my ($t) = @_; return $t->getNodeValue()->description(); }); # NOTE: this object has changed, but it still remains # backwards compatible to the older version, see the # DESCRIPTION section below for more details =head1 DESCRIPTION This object has been revised into what I think is more intelligent approach to Visitor objects. This is now a more suitable base class for building your own Visitors. It is also the base class for the visitors found in the B distribution, which includes a number of useful pre-built Visitors. While I have changed a number of things about this module, I have kept it backwards compatible to the old way of using it. So the original example code still works: my @accumulator; my $visitor = Tree::Simple::Visitor->new(sub { my ($tree) = @_; push @accumulator, $tree->getNodeValue(); }, Tree::Simple::Visitor->RECURSIVE); $tree->accept($visitor); print join ", ", @accumulator; # prints "1.0, 2.0, 2.1.0, 3.0" But is better expressed as this: my $visitor = Tree::Simple::Visitor->new(); $tree->accept($visitor); print join ", ", $visitor->getResults(); # prints "1.0, 2.0, 2.1.0, 3.0" This object is still pretty much a wrapper around the Tree::Simple C method, and can be thought of as a depth-first traversal Visitor object. =head1 METHODS =over 4 =item B The new style interface means that all arguments to the constructor are now optional. As a means of defining the usage of the old and new, when no arguments are sent to the constructor, it is assumed that the new style interface is being used. In the new style, the C<$depth> is always assumed to be equivalent to C and the C<$func> argument can be set with C instead. This is the recommended way of doing things now. If you have been using the old way, it is still there, and I will maintain backwards compatibility for a few more version before removing it entirely. If you are using this module (and I do not even know if anyone actually is) you have been warned. Please contact me if this will be a problem. The old style constructor documentation is retained her for reference: The first argument to the constructor is a code reference to a function which expects a B object as its only argument. The second argument is optional, it can be used to set the depth to which the function is applied. If no depth is set, the function is applied to the current B instance. If C<$depth> is set to C, then the function will be applied to the current B instance and all its immediate children. If C<$depth> is set to C, then the function will be applied to the current B instance and all its immediate children, and all of their children recursively on down the tree. If no C<$depth> is passed to the constructor, then the function will only be applied to the current B object and none of its children. =item B Based upon the value of C<$boolean>, this will tell the visitor to collect the trunk of the tree as well. It is defaulted to false (C<0>) in the new style interface, but is defaulted to true (C<1>) in the old style interface. =item B This method returns the CODE reference set with C argument. =item B This method clears node filter field. =item B This method accepts a CODE reference as its C<$filter_function> argument. This code reference is used to filter the tree nodes as they are collected. This can be used to customize output, or to gather specific information from a more complex tree node. The filter function should accept a single argument, which is the current Tree::Simple object. =item B This method returns the accumulated results of the application of the node filter to the tree. =item B This method should not really be used outside of this class, as it just would not make any sense to. It is included in this class and in this documentation to facilitate subclassing of this class for your own needs. If you desire to clear the results, then you can simply call C with no argument. =item B The C method accepts a B and applies the function set in C or C appropriately. The results of this application can be retrieved with C =back =head1 CONSTANTS These constants are part of the old-style interface, and therefore will eventually be deprecated. =over 4 =item B If passed this constant in the constructor, the function will be applied recursively down the hierarchy of B objects. =item B If passed this constant in the constructor, the function will be applied to the immediate children of the B object. =back =head1 BUGS None that I am aware of. The code is pretty thoroughly tested (see B section in B) and is based on an (non-publicly released) module which I had used in production systems for about 2 years without incident. Of course, if you find a bug, let me know, and I will be sure to fix it. =head1 SEE ALSO I have written a set of pre-built Visitor objects, available on CPAN as B. =head1 AUTHOR stevan little, Estevan@iinteractive.comE =head1 REPOSITORY L. =head1 COPYRIGHT AND LICENSE Copyright 2004-2006 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Tree-Simple-1.29/lib/Tree/Simple.pm0000644000175000017500000012764212712222047015220 0ustar ronronpackage Tree::Simple; use strict; use warnings; our $VERSION = '1.29'; use Scalar::Util qw(blessed); ## ----------------------------------------------- ## Tree::Simple ## ----------------------------------------------- my $USE_WEAK_REFS; sub import { shift; return unless @_; if (lc($_[0]) eq 'use_weak_refs') { $USE_WEAK_REFS++; *Tree::Simple::weaken = \&Scalar::Util::weaken; } } ## class constants use constant ROOT => "root"; ### constructor sub new { my ($_class, $node, $parent) = @_; my $class = ref($_class) || $_class; my $tree = bless({}, $class); $tree->_init($node, $parent, []); return $tree; } ### ----------------------------------------------- ### methods ### ----------------------------------------------- ## ----------------------------------------------- ## private methods sub _init { my ($self, $node, $parent, $children) = @_; # set the value of the unique id ($self->{_uid}) = ("$self" =~ /\((.*?)\)$/); # set the value of the node $self->{_node} = $node; # and set the value of _children $self->{_children} = $children; $self->{_height} = 1; $self->{_width} = 1; # Now check our $parent value if (defined($parent)) { if (blessed($parent) && $parent->isa("Tree::Simple")) { # and set it as our parent $parent->addChild($self); } elsif ($parent eq $self->ROOT) { $self->_setParent( $self->ROOT ); } else { die "Insufficient Arguments : parent argument must be a Tree::Simple object"; } } else { $self->_setParent( $self->ROOT ); } } sub _setParent { my ($self, $parent) = @_; (defined($parent) && (($parent eq $self->ROOT) || (blessed($parent) && $parent->isa("Tree::Simple")))) || die "Insufficient Arguments : parent also must be a Tree::Simple object"; $self->{_parent} = $parent; if ($parent eq $self->ROOT) { $self->{_depth} = -1; } else { weaken($self->{_parent}) if $USE_WEAK_REFS; $self->{_depth} = $parent->getDepth() + 1; } } sub _detachParent { return if $USE_WEAK_REFS; my ($self) = @_; $self->{_parent} = undef; } sub _setHeight { my ($self, $child) = @_; my $child_height = $child->getHeight(); return if ($self->{_height} >= $child_height + 1); $self->{_height} = $child_height + 1; # and now bubble up to the parent (unless we are the root) $self->getParent()->_setHeight($self) unless $self->isRoot(); } sub _setWidth { my ($self, $child_width) = @_; $self->{_width} += $child_width; # and now bubble up to the parent (unless we are the root) $self->getParent()->_setWidth($child_width) unless $self->isRoot(); } ## ----------------------------------------------- ## mutators sub setNodeValue { my ($self, $node_value) = @_; (defined($node_value)) || die "Insufficient Arguments : must supply a value for node"; $self->{_node} = $node_value; } sub setUID { my ($self, $uid) = @_; ($uid) || die "Insufficient Arguments : Custom Unique ID's must be a true value"; $self->{_uid} = $uid; } ## ----------------------------------------------- ## child methods sub addChild { splice @_, 1, 0, $_[0]->getChildCount; goto &insertChild; } sub addChildren { splice @_, 1, 0, $_[0]->getChildCount; goto &insertChildren; } sub _insertChildAt { my ($self, $index, @trees) = @_; (defined($index)) || die "Insufficient Arguments : Cannot insert child without index"; # check the bounds of our children # against the index given my $max = $self->getChildCount(); ($index <= $max) || die "Index Out of Bounds : got ($index) expected no more than (" . $self->getChildCount() . ")"; (@trees) || die "Insufficient Arguments : no tree(s) to insert"; my($new_width) = 0; foreach my $tree (@trees) { (blessed($tree) && $tree->isa("Tree::Simple")) || die "Insufficient Arguments : Child must be a Tree::Simple object"; $tree->_setParent($self); $self->_setHeight($tree); $new_width += getWidth($tree); $tree->fixDepth() unless $tree->isLeaf(); } $self -> _setWidth($new_width - ($self -> isLeaf ? 1 : 0) ); # if index is zero, use this optimization if ($index == 0) { unshift @{$self->{_children}} => @trees; } # if index is equal to the number of children # then use this optimization elsif ($index == $max) { push @{$self->{_children}} => @trees; } # otherwise do some heavy lifting here else { splice @{$self->{_children}}, $index, 0, @trees; } $self; } *insertChildren = \&_insertChildAt; # insertChild is really the same as insertChildren, you are just # inserting an array of one tree *insertChild = \&insertChildren; sub removeChildAt { my ($self, $index) = @_; (defined($index)) || die "Insufficient Arguments : Cannot remove child without index."; ($self->getChildCount() != 0) || die "Illegal Operation : There are no children to remove"; # check the bounds of our children # against the index given ($index < $self->getChildCount()) || die "Index Out of Bounds : got ($index) expected no more than (" . $self->getChildCount() . ")"; my $removed_child; # if index is zero, use this optimization if ($index == 0) { $removed_child = shift @{$self->{_children}}; } # if index is equal to the number of children # then use this optimization elsif ($index == $#{$self->{_children}}) { $removed_child = pop @{$self->{_children}}; } # otherwise do some heavy lifting here else { $removed_child = $self->{_children}->[$index]; splice @{$self->{_children}}, $index, 1; } # make sure we fix the height $self->fixHeight(); $self->fixWidth(); # make sure that the removed child # is no longer connected to the parent # so we change its parent to ROOT $removed_child->_setParent($self->ROOT); # and now we make sure that the depth # of the removed child is aligned correctly $removed_child->fixDepth() unless $removed_child->isLeaf(); # return this removed child # it is the responsibility # of the user of this module # to properly dispose of this # child (and all its sub-children) return $removed_child; } sub removeChild { my ($self, $child_to_remove) = @_; (defined($child_to_remove)) || die "Insufficient Arguments : you must specify a child to remove"; # maintain backwards compatibility # so any non-ref arguments will get # sent to removeChildAt return $self->removeChildAt($child_to_remove) unless ref($child_to_remove); # now that we are confident it's a reference # make sure it is the right kind (blessed($child_to_remove) && $child_to_remove->isa("Tree::Simple")) || die "Insufficient Arguments : Only valid child type is a Tree::Simple object"; my $index = 0; foreach my $child ($self->getAllChildren()) { ("$child" eq "$child_to_remove") && return $self->removeChildAt($index); $index++; } die "Child Not Found : cannot find object ($child_to_remove) in self"; } sub getIndex { my ($self) = @_; return -1 if $self->{_parent} eq $self->ROOT; my $index = 0; foreach my $sibling ($self->{_parent}->getAllChildren()) { ("$sibling" eq "$self") && return $index; $index++; } } ## ----------------------------------------------- ## Sibling methods # these addSibling and addSiblings functions # just pass along their arguments to the addChild # and addChildren method respectively, this # eliminates the need to overload these method # in things like the Keyable Tree object sub addSibling { my ($self, @args) = @_; (!$self->isRoot()) || die "Insufficient Arguments : cannot add a sibling to a ROOT tree"; $self->{_parent}->addChild(@args); } sub addSiblings { my ($self, @args) = @_; (!$self->isRoot()) || die "Insufficient Arguments : cannot add siblings to a ROOT tree"; $self->{_parent}->addChildren(@args); } sub insertSiblings { my ($self, @args) = @_; (!$self->isRoot()) || die "Insufficient Arguments : cannot insert sibling(s) to a ROOT tree"; $self->{_parent}->insertChildren(@args); } # insertSibling is really the same as # insertSiblings, you are just inserting # and array of one tree *insertSibling = \&insertSiblings; # I am not permitting the removal of siblings # as I think in general it is a bad idea ## ----------------------------------------------- ## accessors sub getUID { $_[0]{_uid} } sub getParent { $_[0]{_parent} } sub getDepth { $_[0]{_depth} } sub getNodeValue { $_[0]{_node} } sub getWidth { $_[0]{_width} } sub getHeight { $_[0]{_height} } # for backwards compatibility *height = \&getHeight; sub getChildCount { $#{$_[0]{_children}} + 1 } sub getChild { my ($self, $index) = @_; (defined($index)) || die "Insufficient Arguments : Cannot get child without index"; return $self->{_children}->[$index]; } sub getAllChildren { my ($self) = @_; return wantarray ? @{$self->{_children}} : $self->{_children}; } sub getSibling { my ($self, $index) = @_; (!$self->isRoot()) || die "Insufficient Arguments : cannot get siblings from a ROOT tree"; $self->getParent()->getChild($index); } sub getAllSiblings { my ($self) = @_; (!$self->isRoot()) || die "Insufficient Arguments : cannot get siblings from a ROOT tree"; $self->getParent()->getAllChildren(); } ## ----------------------------------------------- ## informational sub isLeaf { $_[0]->getChildCount == 0 } sub isRoot { my ($self) = @_; return (!defined($self->{_parent}) || $self->{_parent} eq $self->ROOT); } sub size { my ($self) = @_; my $size = 1; foreach my $child ($self->getAllChildren()) { $size += $child->size(); } return $size; } ## ----------------------------------------------- ## misc # NOTE: # Occasionally one wants to have the # depth available for various reasons # of convenience. Sometimes that depth # field is not always correct. # If you create your tree in a top-down # manner, this is usually not an issue # since each time you either add a child # or create a tree you are doing it with # a single tree and not a hierarchy. # If however you are creating your tree # bottom-up, then you might find that # when adding hierarchies of trees, your # depth fields are all out of whack. # This is where this method comes into play # it will recurse down the tree and fix the # depth fields appropriately. # This method is called automatically when # a subtree is added to a child array sub fixDepth { my ($self) = @_; # make sure the tree's depth # is up to date all the way down $self->traverse(sub { my ($tree) = @_; return if $tree->isRoot(); $tree->{_depth} = $tree->getParent()->getDepth() + 1; } ); } # NOTE: # This method is used to fix any height # discrepancies which might arise when # you remove a sub-tree sub fixHeight { my ($self) = @_; # we must find the tallest sub-tree # and use that to define the height my $max_height = 0; unless ($self->isLeaf()) { foreach my $child ($self->getAllChildren()) { my $child_height = $child->getHeight(); $max_height = $child_height if ($max_height < $child_height); } } # if there is no change, then we # need not bubble up through the # parents return if ($self->{_height} == ($max_height + 1)); # otherwise ... $self->{_height} = $max_height + 1; # now we need to bubble up through the parents # in order to rectify any issues with height $self->getParent()->fixHeight() unless $self->isRoot(); } sub fixWidth { my ($self) = @_; my $fixed_width = 0; $fixed_width += $_->getWidth() foreach $self->getAllChildren(); $self->{_width} = $fixed_width; $self->getParent()->fixWidth() unless $self->isRoot(); } sub traverse { my ($self, $func, $post) = @_; (defined($func)) || die "Insufficient Arguments : Cannot traverse without traversal function"; (ref($func) eq "CODE") || die "Incorrect Object Type : traversal function is not a function"; (ref($post) eq "CODE") || die "Incorrect Object Type : post traversal function is not a function" if defined($post); foreach my $child ($self->getAllChildren()) { $func->($child); $child->traverse($func, $post); defined($post) && $post->($child); } } # this is an improved version of the # old accept method, it now it more # accepting of its arguments sub accept { my ($self, $visitor) = @_; # it must be a blessed reference and ... (blessed($visitor) && # either a Tree::Simple::Visitor object, or ... ($visitor->isa("Tree::Simple::Visitor") || # it must be an object which has a 'visit' method available $visitor->can('visit'))) || die "Insufficient Arguments : You must supply a valid Visitor object"; $visitor->visit($self); } ## ----------------------------------------------- ## cloning sub clone { my ($self) = @_; # first clone the value in the node my $cloned_node = _cloneNode($self->getNodeValue()); # create a new Tree::Simple object # here with the cloned node, however # we do not assign the parent node # since it really does not make a lot # of sense. To properly clone it would # be to clone back up the tree as well, # which IMO is not intuitive. So in essence # when you clone a tree, you detach it from # any parentage it might have my $clone = $self->new($cloned_node); # however, because it is a recursive thing # when you clone all the children, and then # add them to the clone, you end up setting # the parent of the children to be that of # the clone (which is correct) $clone->addChildren( map { $_->clone() } $self->getAllChildren() ) unless $self->isLeaf(); # return the clone return $clone; } # this allows cloning of single nodes while # retaining connections to a tree, this is sloppy sub cloneShallow { my ($self) = @_; my $cloned_tree = { %{$self} }; bless($cloned_tree, ref($self)); # just clone the node (if you can) $cloned_tree->setNodeValue(_cloneNode($self->getNodeValue())); return $cloned_tree; } # this is a helper function which # recursively clones the node sub _cloneNode { my ($node, $seen) = @_; # create a cache if we don't already # have one to prevent circular refs # from being copied more than once $seen = {} unless defined $seen; # now here we go... my $clone; # if it is not a reference, then lets just return it return $node unless ref($node); # if it is in the cache, then return that return $seen->{$node} if exists ${$seen}{$node}; # if it is an object, then ... if (blessed($node)) { # see if we can clone it if ($node->can('clone')) { $clone = $node->clone(); } # otherwise respect that it does # not want to be cloned else { $clone = $node; } } else { # if the current slot is a scalar reference, then # dereference it and copy it into the new object if (ref($node) eq "SCALAR" || ref($node) eq "REF") { my $var = ""; $clone = \$var; ${$clone} = _cloneNode(${$node}, $seen); } # if the current slot is an array reference # then dereference it and copy it elsif (ref($node) eq "ARRAY") { $clone = [ map { _cloneNode($_, $seen) } @{$node} ]; } # if the current reference is a hash reference # then dereference it and copy it elsif (ref($node) eq "HASH") { $clone = {}; foreach my $key (keys %{$node}) { $clone->{$key} = _cloneNode($node->{$key}, $seen); } } else { # all other ref types are not copied $clone = $node; } } # store the clone in the cache and $seen->{$node} = $clone; # then return the clone return $clone; } ## ----------------------------------------------- ## Desctructor sub DESTROY { # if we are using weak refs # we don't need to worry about # destruction, it will just happen return if $USE_WEAK_REFS; my ($self) = @_; # we want to detach all our children from # ourselves, this will break most of the # connections and allow for things to get # reaped properly if ($self->{_children}) { foreach my $child (@{$self->{_children}}) { defined $child && $child->_detachParent(); } } # we do not need to remove or undef the _children # of the _parent fields, this will cause some # unwanted releasing of connections. } ## ----------------------------------------------- ## end Tree::Simple ## ----------------------------------------------- 1; __END__ =head1 NAME Tree::Simple - A simple tree object =head1 SYNOPSIS use Tree::Simple; # make a tree root my $tree = Tree::Simple->new("0", Tree::Simple->ROOT); # explicitly add a child to it $tree->addChild(Tree::Simple->new("1")); # specify the parent when creating # an instance and it adds the child implicitly my $sub_tree = Tree::Simple->new("2", $tree); # chain method calls $tree->getChild(0)->addChild(Tree::Simple->new("1.1")); # add more than one child at a time $sub_tree->addChildren( Tree::Simple->new("2.1"), Tree::Simple->new("2.2") ); # add siblings $sub_tree->addSibling(Tree::Simple->new("3")); # insert children a specified index $sub_tree->insertChild(1, Tree::Simple->new("2.1a")); # clean up circular references $tree->DESTROY(); =head1 DESCRIPTION This module in an fully object-oriented implementation of a simple n-ary tree. It is built upon the concept of parent-child relationships, so therefore every B object has both a parent and a set of children (who themselves may have children, and so on). Every B object also has siblings, as they are just the children of their immediate parent. It is can be used to model hierarchal information such as a file-system, the organizational structure of a company, an object inheritance hierarchy, versioned files from a version control system or even an abstract syntax tree for use in a parser. It makes no assumptions as to your intended usage, but instead simply provides the structure and means of accessing and traversing said structure. This module uses exceptions and a minimal Design By Contract style. All method arguments are required unless specified in the documentation, if a required argument is not defined an exception will usually be thrown. Many arguments are also required to be of a specific type, for instance the C<$parent> argument to the constructor B be a B object or an object derived from B, otherwise an exception is thrown. This may seems harsh to some, but this allows me to have the confidence that my code works as I intend, and for you to enjoy the same level of confidence when using this module. Note however that this module does not use any Exception or Error module, the exceptions are just strings thrown with C. I consider this module to be production stable, it is based on a module which has been in use on a few production systems for approx. 2 years now with no issue. The only difference is that the code has been cleaned up a bit, comments added and the thorough tests written for its public release. I am confident it behaves as I would expect it to, and is (as far as I know) bug-free. I have not stress-tested it under extreme duress, but I do not so much intend for it to be used in that type of situation. If this module cannot keep up with your Tree needs, i suggest switching to one of the modules listed in the L section below. =head1 CONSTANTS =over 4 =item B This class constant serves as a placeholder for the root of our tree. If a tree does not have a parent, then it is considered a root. =back =head1 METHODS =head2 Constructor =over 4 =item B The constructor accepts two arguments a C<$node> value and an optional C<$parent>. The C<$node> value can be any scalar value (which includes references and objects). The optional C<$parent> value must be a B object, or an object derived from B. Setting this value implies that your new tree is a child of the parent tree, and therefore adds it to the children of that parent. If the C<$parent> is not specified then its value defaults to ROOT. =back =head2 Mutator Methods =over 4 =item B This sets the node value to the scalar C<$node_value>, an exception is thrown if C<$node_value> is not defined. =item B This allows you to set your own unique ID for this specific Tree::Simple object. A default value derived from the hex address of the object is provided for you, so use of this method is entirely optional. It is the responsibility of the user to ensure the value has uniqueness, all that is tested by this method is that C<$uid> is a true value (evaluates to true in a boolean context). For even more information about the Tree::Simple UID see the C method. =item B This method accepts only B objects or objects derived from B, an exception is thrown otherwise. This method will append the given C<$tree> to the end of the children list, and set up the correct parent-child relationships. This method is set up to return its invocant so that method call chaining can be possible. Such as: my $tree = Tree::Simple->new("root")->addChild(Tree::Simple->new("child one")); Or the more complex: my $tree = Tree::Simple->new("root")->addChild( Tree::Simple->new("1.0")->addChild( Tree::Simple->new("1.0.1") ) ); =item B This method accepts an array of B objects, and adds them to the children list. Like C this method will return its invocant to allow for method call chaining. =item B This method accepts a numeric C<$index> and a B object (C<$tree>), and inserts the C<$tree> into the children list at the specified C<$index>. This results in the shifting down of all children after the C<$index>. The C<$index> is checked to be sure it is the bounds of the child list, if it out of bounds an exception is thrown. The C<$tree> argument is verified to be a B or B derived object, if this condition fails, an exception is thrown. =item B This method functions much as insertChild does, but instead of inserting a single B, it inserts an array of B objects. It too bounds checks the value of C<$index> and type checks the objects in C<@trees> just as C does. =item B ($child | $index)> Accepts two different arguments. If given a B object (C<$child>), this method finds that specific C<$child> by comparing it with all the other children until it finds a match. At which point the C<$child> is removed. If no match is found, and exception is thrown. If a non-B object is given as the C<$child> argument, an exception is thrown. This method also accepts a numeric C<$index> and removes the child found at that index within the list of children. The C<$index> is bounds checked, if this condition fail, an exception is thrown. When a child is removed, it results in the shifting up of all children after it, and the removed child is returned. The removed child is properly disconnected from the tree and all its references to its old parent are removed. However, in order to properly clean up and circular references the removed child might have, it is advised to call the C method. See the L section for more information. =item B =item B =item B =item B The C, C, C and C methods pass along their arguments to the C, C, C and C methods of their parent object respectively. This eliminates the need to overload these methods in subclasses which may have specialized versions of the *Child(ren) methods. The one exceptions is that if an attempt it made to add or insert siblings to the B of the tree then an exception is thrown. =back B There is no C method as I felt it was probably a bad idea. The same effect can be achieved by manual upwards traversal. =head2 Accessor Methods =over 4 =item B This returns the value stored in the node field of the object. =item B This returns the unique ID associated with this particular tree. This can be custom set using the C method, or you can just use the default. The default is the hex-address extracted from the stringified Tree::Simple object. This may not be a I unique identifier, but it should be adequate for at least the current instance of your perl interpreter. If you need a UUID, one can be generated with an outside module (there are many to choose from on CPAN) and the C method (see above). =item B This returns the child (a B object) found at the specified C<$index>. Note that we do use standard zero-based array indexing. =item B This returns an array of all the children (all B objects). It will return an array reference in scalar context. =item B =item B Much like C and C, these two methods simply call C and C on the parent of the invocant. =item B Returns a number representing the depth of the invocant within the hierarchy of B objects. B A C tree has the depth of -1. This be because Tree::Simple assumes that a root node will usually not contain data, but just be an anchor for the data-containing branches. This may not be intuitive in all cases, so I mention it here. =item B Returns the parent of the invocant, which could be either B or a B object. =item B Returns a number representing the length of the longest path from the current tree to the furthest leaf node. =item B Returns the a number representing the breadth of the current tree, basically it is a count of all the leaf nodes. =item B Returns the number of children the invocant contains. =item B Returns the index of this tree within its sibling list. Returns -1 if the tree is the root. =back =head2 Predicate Methods =over 4 =item B Returns true (1) if the invocant does not have any children, false (0) otherwise. =item B Returns true (1) if the invocant has a "parent" of B, returns false (0) otherwise. =back =head2 Recursive Methods =over 4 =item B This method accepts two arguments a mandatory C<$func> and an optional C<$postfunc>. If the argument C<$func> is not defined then an exception is thrown. If C<$func> or C<$postfunc> are not in fact CODE references then an exception is thrown. The function C<$func> is then applied recursively to all the children of the invocant. If given, the function C<$postfunc> will be applied to each child after the children of the child have been traversed. Here is an example of a traversal function that will print out the hierarchy as a tabbed in list. $tree->traverse(sub { my ($_tree) = @_; print (("\t" x $_tree->getDepth()), $_tree->getNodeValue(), "\n"); }); Here is an example of a traversal function that will print out the hierarchy in an XML-style format. $tree->traverse(sub { my ($_tree) = @_; print ((' ' x $_tree->getDepth()), '<', $_tree->getNodeValue(),'>',"\n"); }, sub { my ($_tree) = @_; print ((' ' x $_tree->getDepth()), 'getNodeValue(),'>',"\n"); }); =item B Returns the total number of nodes in the current tree and all its sub-trees. =item B This method has also been B in favor of the C method above, it remains as an alias to C for backwards compatibility. B This is also no longer a recursive method which get's it's value on demand, but a value stored in the Tree::Simple object itself, hopefully making it much more efficient and usable. =back =head2 Visitor Methods =over 4 =item B It accepts either a B object (which includes classes derived from B), or an object who has the C method available (tested with C<$visitor-Ecan('visit')>). If these qualifications are not met, and exception will be thrown. We then run the Visitor C method giving the current tree as its argument. I have also created a number of Visitor objects and packaged them into the B. =back =head2 Cloning Methods Cloning a tree can be an extremely expensive operation for large trees, so we provide two options for cloning, a deep clone and a shallow clone. When a Tree::Simple object is cloned, the node is deep-copied in the following manner. If we find a normal scalar value (non-reference), we simply copy it. If we find an object, we attempt to call C on it, otherwise we just copy the reference (since we assume the object does not want to be cloned). If we find a SCALAR, REF reference we copy the value contained within it. If we find a HASH or ARRAY reference we copy the reference and recursively copy all the elements within it (following these exact guidelines). We also do our best to assure that circular references are cloned only once and connections restored correctly. This cloning will not be able to copy CODE, RegExp and GLOB references, as they are pretty much impossible to clone. We also do not handle C objects, and they will simply be copied as plain references, and not re-C. =over 4 =item B The clone method does a full deep-copy clone of the object, calling C recursively on all its children. This does not call C on the parent tree however. Doing this would result in a slowly degenerating spiral of recursive death, so it is not recommended and therefore not implemented. What happens is that the tree instance that C is actually called upon is detached from the tree, and becomes a root node, all if the cloned children are then attached as children of that tree. I personally think this is more intuitive then to have the cloning crawl back I the tree is not what I think most people would expect. =item B This method is an alternate option to the plain C method. This method allows the cloning of single B object while retaining connections to the rest of the tree/hierarchy. =back =head2 Misc. Methods =over 4 =item B To avoid memory leaks through uncleaned-up circular references, we implement the C method. This method will attempt to call C on each of its children (if it has any). This will result in a cascade of calls to C on down the tree. It also cleans up it's parental relations as well. Because of perl's reference counting scheme and how that interacts with circular references, if you want an object to be properly reaped you should manually call C. This is especially necessary if your object has any children. See the section on L for more information. =item B Tree::Simple will manage the depth field for you using this method. You should never need to call it on your own, however if you ever did need to, here is it. Running this method will traverse your all the sub-trees of the invocant, correcting the depth as it goes. =item B Tree::Simple will manage the height field for you using this method. You should never need to call it on your own, however if you ever did need to, here is it. Running this method will correct the heights of the current tree and all ancestors heights too. =item B Tree::Simple will manage the width field for you using this method. You should never need to call it on your own, however if you ever did need to, here is it. Running this method will correct the widths of the current tree and all ancestors widths too. =back =head2 Private Methods I would not normally document private methods, but in case you need to subclass Tree::Simple, here they are. =over 4 =item B<_init ($node, $parent, $children)> This method is here largely to facilitate subclassing. This method is called by new to initialize the object, where new has the primary responsibility of creating the instance. =item B<_setParent ($parent)> This method sets up the parental relationship. It is for internal use only. =item B<_setHeight ($child)> This method will set the height field based upon the height of the given C<$child>. =back =head1 CIRCULAR REFERENCES I have revised the model by which Tree::Simple deals with circular references. In the past all circular references had to be manually destroyed by calling DESTROY. The call to DESTROY would then call DESTROY on all the children, and therefore cascade down the tree. This however was not always what was needed, nor what made sense, so I have now revised the model to handle things in what I feel is a more consistent and sane way. Circular references are now managed with the simple idea that the parent makes the decisions for the child. This means that child-to-parent references are weak, while parent-to-child references are strong. So if a parent is destroyed it will force all the children to detach from it, however, if a child is destroyed it will not be detached from the parent. =head2 Optional Weak References By default, you are still required to call DESTROY in order for things to happen. However I have now added the option to use weak references, which alleviates the need for the manual call to DESTROY and allows Tree::Simple to manage this automatically. This is accomplished with a compile time setting like this: use Tree::Simple 'use_weak_refs'; And from that point on Tree::Simple will use weak references to allow for reference counting to clean things up properly. For those who are unfamiliar with weak references, and how they affect the reference counts, here is a simple illustration. First is the normal model that Tree::Simple uses: +---------------+ | Tree::Simple1 |<---------------------+ +---------------+ | | parent | | | children |-+ | +---------------+ | | | | | +---------------+ | +->| Tree::Simple2 | | +---------------+ | | parent |-+ | children | +---------------+ Here, Tree::Simple1 has a reference count of 2 (one for the original variable it is assigned to, and one for the parent reference in Tree::Simple2), and Tree::Simple2 has a reference count of 1 (for the child reference in Tree::Simple1). Now, with weak references: +---------------+ | Tree::Simple1 |....................... +---------------+ : | parent | : | children |-+ : <--[ weak reference ] +---------------+ | : | : | +---------------+ : +->| Tree::Simple2 | : +---------------+ : | parent |.. | children | +---------------+ Now Tree::Simple1 has a reference count of 1 (for the variable it is assigned to) and 1 weakened reference (for the parent reference in Tree::Simple2). And Tree::Simple2 has a reference count of 1, just as before. =head1 BUGS None that I am aware of. The code is pretty thoroughly tested (see L below) and is based on an (non-publicly released) module which I had used in production systems for about 3 years without incident. Of course, if you find a bug, let me know, and I will be sure to fix it. =head1 CODE COVERAGE I use L to test the code coverage of my tests, below is the L report on the test suite. ---------------------------- ------ ------ ------ ------ ------ ------ ------ File stmt branch cond sub pod time total ---------------------------- ------ ------ ------ ------ ------ ------ ------ Tree/Simple.pm 99.6 96.0 92.3 100.0 97.0 95.5 98.0 Tree/Simple/Visitor.pm 100.0 96.2 88.2 100.0 100.0 4.5 97.7 ---------------------------- ------ ------ ------ ------ ------ ------ ------ Total 99.7 96.1 91.1 100.0 97.6 100.0 97.9 ---------------------------- ------ ------ ------ ------ ------ ------ ------ =head1 SEE ALSO I have written a number of other modules which use or augment this module, they are describes below and available on CPAN. =over 4 =item L - A module for parsing formatted files into Tree::Simple hierarchies =item L - For viewing Tree::Simple hierarchies in various output formats =item L - Useful Visitor objects for Tree::Simple objects =item L - If you are looking for a binary tree, check this one out =back Also, the author of L and I have worked together to make sure that B and his module work well together. If you need a quick and handy way to dump out a Tree::Simple hierarchy, this module does an excellent job (and plenty more as well). I have also recently stumbled upon some packaged distributions of Tree::Simple for the various Unix flavors. Here are some links: =over 4 =item FreeBSD Port - L =item Debian Package - L =item Linux RPM - L =back =head1 OTHER TREE MODULES There are a few other Tree modules out there, here is a quick comparison between B and them. Obviously I am biased, so take what I say with a grain of salt, and keep in mind, I wrote B because I could not find a Tree module that suited my needs. If B does not fit your needs, I recommend looking at these modules. Please note that I am only listing Tree::* modules I am familiar with here, if you think I have missed a module, please let me know. I have also seen a few tree-ish modules outside of the Tree::* namespace, but most of them are part of another distribution (B, B, etc) and are likely specialized in purpose. =over 4 =item L This module seems pretty stable and very robust with a lot of functionality. But it> only comes with 1 sophisticated test, t/cut.and.paste.subtrees.t. While I am sure the author tested his code, I would feel better if I was able to see that. The module is approx. 3000 lines with POD, and 1,500 without the POD. The shear depth and detail of the documentation and the ratio of code to documentation is impressive, and not to be taken lightly. But given that it is a well known fact that the likeliness of bugs increases along side the size of the code, I do not feel comfortable with large modules like this which have no tests. All this said, I am not a huge fan of the API either, I prefer the gender neutral approach in B to the mother/daughter style of B. I also feel very strongly that B is trying to do much more than makes sense in a single module, and is offering too many ways to do the same or similar things. However, of all the Tree::* modules out there, B seems to be one of the favorites, so it may be worth investigating. =item L I am not very familiar with this module, however, I have heard some good reviews of it, so I thought it deserved mention here. I believe it is based upon C++ code found in the book I by Robert Sedgwick. It uses a number of interesting ideas, such as a ::Handle object to traverse the tree with (similar to Visitors, but also seem to be to be kind of like a cursor). However, like B, it is somewhat lacking in tests and has only 6 tests in its suite. It also has one glaring bug, which is that there is currently no way to remove a child node. =item L It is a (somewhat) direct translation of the N-ary tree from the GLIB library, and the API is based on that. GLIB is a C library, which means this is a very C-ish API. That does not appeal to me, it might to you, to each their own. This module is similar in intent to B. It implements a tree with I branches and has polymorphic node containers. It implements much of the same methods as B and a few others on top of that, but being based on a C library, is not very OO. In most of the method calls the C<$self> argument is not used and the second argument C<$node> is. B is a much more OO module than B, so while they are similar in functionality they greatly differ in implementation style. =item L This module is pretty old, it has not been updated since Oct. 31, 1999 and is still on version 0.01. It also seems to be (from the limited documentation) a binary and a balanced binary tree, B is an I-ary tree, and makes no attempt to balance anything. =item L This module is older than B, last update was Sept. 24th, 1999. It seems to be a special purpose tree, for storing and accessing strings, not general purpose like B. =item L This module is an XS implementation of the above tree type. =item L This too is a specialized tree type, it sounds similar to the B, but it much newer (latest release in 2003). It seems specialized for the lookup and retrieval of information like a hash. =item L Is a wrapper for a C++ library, whereas B is pure-perl. It also seems to be a more specialized implementation of a tree, therefore not really the same as B. =item L Is a wrapper around a C library, again B is pure-perl. The author describes FAT-trees as a combination of a Tree and an array. It looks like a pretty mean and lean module, and good if you need speed and are implementing a custom data-store of some kind. The author points out too that the module is designed for embedding and there is not default embedding, so you cannot really use it "out of the box". =back =head1 ACKNOWLEDGEMENTS =over 4 =item Thanks to Nadim Ibn Hamouda El Khemir for making L work with B. =item Thanks to Brett Nuske for his idea for the C and C methods. =item Thanks to whomever submitted the memory leak bug to RT (#7512). =item Thanks to Mark Thomas for his insight into how to best handle the I and I properties without unnecessary recursion. =item Thanks for Mark Lawrence for the &traverse post-func patch, tests and docs. =back =head1 AUTHOR Stevan Little, Estevan@iinteractive.comE Rob Kinyon, Erob@iinteractive.comE Ron Savage Eron@savage.net.auE has taken over maintenance as of V 1.19. =head1 REPOSITORY L. =head1 COPYRIGHT AND LICENSE Copyright 2004-2006 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Tree-Simple-1.29/Changelog.ini0000644000175000017500000002534212712222047014346 0ustar ronron[Module] Name=Tree::Simple Changelog.Creator=Module::Metadata::Changes V 2.09 Changelog.Parser=Config::IniFiles V 2.88 [V 1.28] Date=2016-04-27T17:35:00 Comments= < includeTruck(1). - RT#30032: Adopt patch from Moses Amaro. With thanx. - RT#38607: Reject. Suppressing deep recursion warnings should not normally be done. Sub-class! - RT#40407: Adopt patch from David Cryer. With thanx. - RT#84797: Reject. Changing the return value of setUID could break any amount of code. EOT [V 1.18] Date=2007-11-11T12:00:00 Comments=- fixing version string to not choke on 5.10 (RT #29746). [V 1.17] Date=2006-10-23T12:00:00 Comments= < "Test::Memory::Cycle required for testing memory leaks" if $@; plan tests => 51; use_ok('Tree::Simple'); #diag "parental connections must be destroyed manually"; { #diag "verify the problem exists"; my $tree2 = Tree::Simple->new("2"); ok($tree2->isRoot(), '... tree2 is a ROOT'); my $tree1_UID; { my $tree1 = Tree::Simple->new("1"); $tree1_UID = $tree1->getUID(); $tree1->addChild($tree2); ok(!$tree2->isRoot(), '... now tree2 is not a ROOT'); memory_cycle_exists($tree2, '... there is a cycle in tree2'); } memory_cycle_exists($tree2, '... tree1 is still connected with tree2'); ok(!$tree2->isRoot(), '... now tree2 is not a ROOT'); ok(defined($tree2->getParent()), '... now tree2s parent is still defined'); is($tree2->getParent()->getUID(), $tree1_UID, '... and tree2s parent is tree1'); } { #diag "this fixes the problem"; my $tree2 = Tree::Simple->new("2"); ok($tree2->isRoot(), '... tree2 is a ROOT'); { my $tree1 = Tree::Simple->new("1"); $tree1->addChild($tree2); ok(!$tree2->isRoot(), '... now tree2 is not a ROOT'); memory_cycle_exists($tree2, '... there is a cycle in tree2'); $tree1->DESTROY(); } memory_cycle_ok($tree2, '... calling DESTORY on tree1 broke the connection with tree2'); ok($tree2->isRoot(), '... now tree2 is a ROOT again'); ok(!defined($tree2->getParent()), '... now tree2s parent is no longer defined'); } #diag "expand the original problem and see how it effects children"; { my $tree2 = Tree::Simple->new("2"); ok($tree2->isRoot(), '... tree2 is a ROOT'); ok($tree2->isLeaf(), '... tree2 is a Leaf'); my $tree3 = Tree::Simple->new("3"); ok($tree3->isRoot(), '... tree3 is a ROOT'); ok($tree3->isLeaf(), '... tree3 is a Leaf'); { my $tree1 = Tree::Simple->new("1"); $tree1->addChild($tree2); ok(!$tree2->isRoot(), '... now tree2 is not a ROOT'); $tree2->addChild($tree3); ok(!$tree2->isLeaf(), '... now tree2 is not a Leaf'); ok(!$tree3->isRoot(), '... tree3 is no longer a ROOT'); ok($tree3->isLeaf(), '... but tree3 is still a Leaf'); memory_cycle_exists($tree1, '... there is a cycle in tree1'); memory_cycle_exists($tree2, '... there is a cycle in tree2'); memory_cycle_exists($tree3, '... there is a cycle in tree3'); $tree1->DESTROY(); memory_cycle_exists($tree1, '... there is still a cycle in tree1 because of the children'); } memory_cycle_exists($tree2, '... calling DESTORY on tree1 broke the connection with tree2'); ok($tree2->isRoot(), '... now tree2 is a ROOT again'); ok(!$tree2->isLeaf(), '... now tree2 is not a leaf again'); ok(!defined($tree2->getParent()), '... now tree2s parent is no longer defined'); cmp_ok($tree2->getChildCount(), '==', 1, '... now tree2 has one child'); memory_cycle_exists($tree3, '... calling DESTORY on tree1 did not break the connection betwee tree2 and tree3'); ok(!$tree3->isRoot(), '... now tree3 is not a ROOT'); ok($tree3->isLeaf(), '... now tree3 is still a leaf'); ok(defined($tree3->getParent()), '... now tree3s parent is still defined'); is($tree3->getParent(), $tree2, '... now tree3s parent is still tree2'); } #diag "child connections are strong"; { my $tree1 = Tree::Simple->new("1"); my $tree2_UID; { my $tree2 = Tree::Simple->new("2"); $tree1->addChild($tree2); $tree2_UID = $tree2->getUID(); memory_cycle_exists($tree1, '... tree1 is connected to tree2'); memory_cycle_exists($tree2, '... tree2 is connected to tree1'); $tree2->DESTROY(); # this doesn't make sense to do } memory_cycle_exists($tree1, '... tree2 is still connected to tree1 because child connections are strong'); is($tree1->getChild(0)->getUID(), $tree2_UID, '... tree2 is still connected to tree1'); is($tree1->getChild(0)->getParent(), $tree1, '... tree2s parent is tree1'); cmp_ok($tree1->getChildCount(), '==', 1, '... tree1 has a child count of 1'); } #diag "expand upon this issue"; { my $tree1 = Tree::Simple->new("1"); my $tree2_UID; my $tree3 = Tree::Simple->new("3"); { my $tree2 = Tree::Simple->new("2"); $tree1->addChild($tree2); $tree2_UID = $tree2->getUID(); $tree2->addChild($tree3); memory_cycle_exists($tree1, '... tree1 is connected to tree2'); memory_cycle_exists($tree2, '... tree2 is connected to tree1'); memory_cycle_exists($tree3, '... tree3 is connected to tree2'); $tree2->DESTROY(); # this doesn't make sense to do } memory_cycle_exists($tree1, '... tree2 is still connected to tree1 because child connections are strong'); is($tree1->getChild(0)->getUID(), $tree2_UID, '... tree2 is still connected to tree1'); is($tree1->getChild(0)->getParent(), $tree1, '... tree2s parent is tree1'); cmp_ok($tree1->getChildCount(), '==', 1, '... tree1 has a child count of 1'); cmp_ok($tree1->getChild(0)->getChildCount(), '==', 1, '... tree2 is still connected to tree3'); is($tree1->getChild(0)->getChild(0), $tree3, '... tree2 is still connected to tree3'); } Tree-Simple-1.29/t/21_Tree_Simple_Visitor_test.t0000644000175000017500000000150512220721733017671 0ustar ronron#!/usr/bin/perl use strict; use warnings; use Test::More tests => 2; use Test::Exception; use Tree::Simple; use Tree::Simple::Visitor; BEGIN { use_ok('Tree::Simple::Visitor'); }; # create a visitor instance my $visitor = Tree::Simple::Visitor->new(); $visitor -> includeTrunk(1); # create a tree to visit my $tree = Tree::Simple -> new ( '0.0', Tree::Simple -> ROOT ) -> addChildren ( Tree::Simple -> new('1.0'), Tree::Simple -> new('2.0') -> addChild ( Tree::Simple -> new('2.1.0') ), Tree::Simple -> new('3.0') ); # by default this will collect all the # node values in depth-first order into # our results $tree->accept($visitor); # get our results and print them my($result) = join ', ', $visitor->getResults(); is($result, '0.0, 1.0, 2.0, 2.1.0, 3.0', 'Visit returns correct nodes'); Tree-Simple-1.29/t/14a_Tree_Simple_weak_refs_test.t0000644000175000017500000001100410715644075020350 0ustar ronron#!/usr/bin/perl use strict; use warnings; use Test::More; eval "use Test::Memory::Cycle 1.02"; plan skip_all => "Test::Memory::Cycle required for testing memory leaks" if $@; plan tests => 43; use_ok('Tree::Simple', 'use_weak_refs'); #diag "parental connections are weak"; { my $tree2 = Tree::Simple->new("2"); ok($tree2->isRoot(), '... tree2 is a ROOT'); { my $tree1 = Tree::Simple->new("1"); $tree1->addChild($tree2); ok(!$tree2->isRoot(), '... now tree2 is not a ROOT'); weakened_memory_cycle_exists($tree2, '... there is a weakened cycle in tree2'); } weakened_memory_cycle_ok($tree2, '... tree2 is no longer connected to tree1'); ok($tree2->isRoot(), '... now tree2 is a ROOT again'); ok(!defined($tree2->getParent()), '... now tree2s parent is no longer defined'); } #diag "expand the problem to check child connections"; { my $tree2 = Tree::Simple->new("2"); ok($tree2->isRoot(), '... tree2 is a ROOT'); ok($tree2->isLeaf(), '... tree2 is a Leaf'); my $tree3 = Tree::Simple->new("3"); ok($tree3->isRoot(), '... tree3 is a ROOT'); ok($tree3->isLeaf(), '... tree3 is a Leaf'); { my $tree1 = Tree::Simple->new("1"); $tree1->addChild($tree2); ok(!$tree2->isRoot(), '... now tree2 is not a ROOT'); $tree2->addChild($tree3); ok(!$tree2->isLeaf(), '... now tree2 is not a Leaf'); ok(!$tree3->isRoot(), '... tree3 is no longer a ROOT'); ok($tree3->isLeaf(), '... but tree3 is still a Leaf'); weakened_memory_cycle_exists($tree1, '... there is a cycle in tree1'); weakened_memory_cycle_exists($tree2, '... there is a cycle in tree2'); weakened_memory_cycle_exists($tree3, '... there is a cycle in tree3'); } weakened_memory_cycle_exists($tree2, '... calling DESTORY on tree1 broke the connection with tree2'); ok($tree2->isRoot(), '... now tree2 is a ROOT again'); ok(!$tree2->isLeaf(), '... now tree2 is a not a leaf again'); ok(!defined($tree2->getParent()), '... now tree2s parent is no longer defined'); cmp_ok($tree2->getChildCount(), '==', 1, '... now tree2 has one child'); weakened_memory_cycle_exists($tree3, '... calling DESTORY on tree1 did not break the connection betwee tree2 and tree3'); ok(!$tree3->isRoot(), '... now tree3 is not a ROOT'); ok($tree3->isLeaf(), '... now tree3 is still a leaf'); ok(defined($tree3->getParent()), '... now tree3s parent is still defined'); is($tree3->getParent(), $tree2, '... now tree3s parent is still tree2'); } #diag "child connections are strong"; { my $tree1 = Tree::Simple->new("1"); my $tree2_UID; { my $tree2 = Tree::Simple->new("2"); $tree1->addChild($tree2); $tree2_UID = $tree2->getUID(); weakened_memory_cycle_exists($tree1, '... tree1 is connected to tree2'); weakened_memory_cycle_exists($tree2, '... tree2 is connected to tree1'); } weakened_memory_cycle_exists($tree1, '... tree2 is still connected to tree1 because child connections are strong'); is($tree1->getChild(0)->getUID(), $tree2_UID, '... tree2 is still connected to tree1'); is($tree1->getChild(0)->getParent(), $tree1, '... tree2s parent is tree1'); cmp_ok($tree1->getChildCount(), '==', 1, '... tree1 has a child count of 1'); } #diag "expand upon this issue"; { my $tree1 = Tree::Simple->new("1"); my $tree2_UID; my $tree3 = Tree::Simple->new("3"); { my $tree2 = Tree::Simple->new("2"); $tree1->addChild($tree2); $tree2_UID = $tree2->getUID(); $tree2->addChild($tree3); weakened_memory_cycle_exists($tree1, '... tree1 is connected to tree2'); weakened_memory_cycle_exists($tree2, '... tree2 is connected to tree1'); weakened_memory_cycle_exists($tree3, '... tree3 is connected to tree2'); } weakened_memory_cycle_exists($tree1, '... tree2 is still connected to tree1 because child connections are strong'); is($tree1->getChild(0)->getUID(), $tree2_UID, '... tree2 is still connected to tree1'); is($tree1->getChild(0)->getParent(), $tree1, '... tree2s parent is tree1'); cmp_ok($tree1->getChildCount(), '==', 1, '... tree1 has a child count of 1'); cmp_ok($tree1->getChild(0)->getChildCount(), '==', 1, '... tree2 is still connected to tree3'); is($tree1->getChild(0)->getChild(0), $tree3, '... tree2 is still connected to tree3'); } Tree-Simple-1.29/t/20_Tree_Simple_Visitor_test.t0000644000175000017500000001530212237273333017676 0ustar ronron#!/usr/bin/perl use strict; use warnings; use Test::More tests => 37; use Test::Exception; BEGIN { use_ok('Tree::Simple::Visitor'); }; use Tree::Simple; my $SIMPLE_SUB = sub { "test sub" }; # execute this otherwise Devel::Cover gives odd stats $SIMPLE_SUB->(); # check that we have a constructor can_ok("Tree::Simple::Visitor", 'new'); # ----------------------------------------------- # test the new style interface # ----------------------------------------------- my $visitor = Tree::Simple::Visitor->new(); isa_ok($visitor, 'Tree::Simple::Visitor'); my $tree = Tree::Simple->new(Tree::Simple->ROOT) ->addChildren( Tree::Simple->new("1") ->addChildren( Tree::Simple->new("1.1"), Tree::Simple->new("1.2") ->addChild(Tree::Simple->new("1.2.1")), Tree::Simple->new("1.3") ), Tree::Simple->new("2"), Tree::Simple->new("3"), ); isa_ok($tree, 'Tree::Simple'); $tree->accept($visitor); can_ok($visitor, 'getResults'); is_deeply( [ $visitor->getResults() ], [ qw(1 1.1 1.2 1.2.1 1.3 2 3)], '... got what we expected'); can_ok($visitor, 'setNodeFilter'); my $node_filter = sub { return "_" . $_[0]->getNodeValue() }; $visitor->setNodeFilter($node_filter); can_ok($visitor, 'getNodeFilter'); is($visitor->getNodeFilter(), "$node_filter", '... got back what we put in'); # visit the tree again to get new results now $tree->accept($visitor); is_deeply( scalar $visitor->getResults(), [ qw(_1 _1.1 _1.2 _1.2.1 _1.3 _2 _3)], '... got what we expected'); # test some exceptions throws_ok { $visitor->setNodeFilter(); } qr/Insufficient Arguments/, '... this should die'; throws_ok { $visitor->setNodeFilter([]); } qr/Insufficient Arguments/, '... this should die'; # ----------------------------------------------- # test the old style interface for backwards # compatibility # ----------------------------------------------- # and that our RECURSIVE constant is properly defined can_ok("Tree::Simple::Visitor", 'RECURSIVE'); # and that our CHILDREN_ONLY constant is properly defined can_ok("Tree::Simple::Visitor", 'CHILDREN_ONLY'); # no depth my $visitor1 = Tree::Simple::Visitor->new($SIMPLE_SUB); isa_ok($visitor1, 'Tree::Simple::Visitor'); # children only my $visitor2 = Tree::Simple::Visitor->new($SIMPLE_SUB, Tree::Simple::Visitor->CHILDREN_ONLY); isa_ok($visitor2, 'Tree::Simple::Visitor'); # recursive my $visitor3 = Tree::Simple::Visitor->new($SIMPLE_SUB, Tree::Simple::Visitor->RECURSIVE); isa_ok($visitor3, 'Tree::Simple::Visitor'); # ----------------------------------------------- # test constructor exceptions # ----------------------------------------------- # we pass a bad depth (string) throws_ok { my $test = Tree::Simple::Visitor->new($SIMPLE_SUB, "Fail") } qr/Insufficient Arguments \: Depth arguement must be either RECURSIVE or CHILDREN_ONLY/, '... we are expecting this error'; # we pass a bad depth (numeric) throws_ok { my $test = Tree::Simple::Visitor->new($SIMPLE_SUB, 100) } qr/Insufficient Arguments \: Depth arguement must be either RECURSIVE or CHILDREN_ONLY/, '... we are expecting this error'; # we pass a non-ref func argument throws_ok { my $test = Tree::Simple::Visitor->new("Fail"); } qr/Insufficient Arguments \: filter function argument must be a subroutine reference/, '... we are expecting this error'; # we pass a non-code-ref func arguement throws_ok { my $test = Tree::Simple::Visitor->new([]); } qr/Insufficient Arguments \: filter function argument must be a subroutine reference/, '... we are expecting this error'; # ----------------------------------------------- # test other exceptions # ----------------------------------------------- # and make sure we can call the visit method can_ok($visitor1, 'visit'); # test no arg throws_ok { $visitor1->visit(); } qr/Insufficient Arguments \: You must supply a valid Tree\:\:Simple object/, '... we are expecting this error'; # test non-ref arg throws_ok { $visitor1->visit("Fail"); } qr/Insufficient Arguments \: You must supply a valid Tree\:\:Simple object/, '... we are expecting this error'; # test non-object ref arg throws_ok { $visitor1->visit([]); } qr/Insufficient Arguments \: You must supply a valid Tree\:\:Simple object/, '... we are expecting this error'; my $BAD_OBJECT = bless({}, "Test"); # test non-Tree::Simple object arg throws_ok { $visitor1->visit($BAD_OBJECT); } qr/Insufficient Arguments \: You must supply a valid Tree\:\:Simple object/, '... we are expecting this error'; # ----------------------------------------------- # Test accept & visit # ----------------------------------------------- # Note: # this test could be made more robust by actually # getting results and testing them from the # Visitor object. But for right now it is good # enough to have the code coverage, and know # all the pieces work. # ----------------------------------------------- # now make a tree my $tree1 = Tree::Simple->new(Tree::Simple->ROOT) ->addChildren( Tree::Simple->new("1.0"), Tree::Simple->new("2.0"), Tree::Simple->new("3.0"), ); isa_ok($tree1, 'Tree::Simple'); cmp_ok($tree1->getChildCount(), '==', 3, '... there are 3 children here'); # and pass the visitor1 to accept lives_ok { $tree1->accept($visitor1); } '.. this passes fine'; # and pass the visitor2 to accept lives_ok { $tree1->accept($visitor2); } '.. this passes fine'; # and pass the visitor3 to accept lives_ok { $tree1->accept($visitor3); } '.. this passes fine'; # ---------------------------------------------------- # test some misc. weirdness to get the coverage up :P # ---------------------------------------------------- # check that includeTrunk works as we expect it to { my $visitor = Tree::Simple::Visitor->new(); ok(!$visitor->includeTrunk(), '... this should be false right now'); $visitor->includeTrunk("true"); ok($visitor->includeTrunk(), '... this should be true now'); $visitor->includeTrunk(undef); ok($visitor->includeTrunk(), '... this should be true still'); $visitor->includeTrunk(""); ok(!$visitor->includeTrunk(), '... this should be false again'); } # check that clearNodeFilter works as we expect it to { my $visitor = Tree::Simple::Visitor->new(); my $filter = sub { "filter" }; $visitor->setNodeFilter($filter); is($visitor->getNodeFilter(), $filter, 'our node filter is set correctly'); $visitor->clearNodeFilter(); ok(! defined($visitor->getNodeFilter()), '... our node filter has now been undefined'); } Tree-Simple-1.29/t/11_Tree_Simple_fixDepth_test.t0000644000175000017500000001152310715644075020017 0ustar ronron#!/usr/bin/perl use strict; use warnings; use Test::More tests => 46; ## ---------------------------------------------------------------------------- ## fixDepth Tests for Tree::Simple ## ---------------------------------------------------------------------------- # NOTE: # This specifically tests the fixDepth function, which is run when a non-leaf # tree is added to a tree. It basically fixes the depth field so that it # correctly reflects the new depth ## ---------------------------------------------------------------------------- use Tree::Simple; # create our tree to later add-in my $tree = Tree::Simple->new("2.1") ->addChildren( Tree::Simple->new("2.1.1"), Tree::Simple->new("2.1.2"), Tree::Simple->new("2.1.2") ); # make sure its a root ok($tree->isRoot(), '... our tree is a root'); # and it is not a leaf ok(!$tree->isLeaf(), '... and it is not a leaf'); # and that its depth is -1 cmp_ok($tree->getDepth(), '==', -1, '... our depth should be -1'); # and check our child count # while we are at it cmp_ok($tree->getChildCount(), '==', 3, '... we have 3 children'); # now check each subtree foreach my $sub_tree ($tree->getAllChildren()) { # they are not root ok(!$sub_tree->isRoot(), '... our subtree is not a root'); # they are leaves ok($sub_tree->isLeaf(), '... however it is a leaf'); # and their parent is $tree is($sub_tree->getParent(), $tree, '... these should both be equal'); # their depth should be 0 cmp_ok($sub_tree->getDepth(), '==', 0, '... our depth should be 0'); # and their siblings should match # the children of their parent is_deeply( [ $tree->getAllChildren() ], [ $sub_tree->getAllSiblings() ], '... our siblings are the same'); } # at this point we know we have a # solid correct structure in $tree # we can now test against that # correctness # now create our other tree # which we will add $tree too my $parent_tree = Tree::Simple->new(Tree::Simple->ROOT); $parent_tree->addChildren( Tree::Simple->new("1"), Tree::Simple->new("2") ); # make sure its a root ok($parent_tree->isRoot(), '... our parent tree is a root'); # and that its not a leaf ok(!$parent_tree->isLeaf(), '... our parent tree is a leaf'); # check the depth, which should be -1 cmp_ok($parent_tree->getDepth(), '==', -1, '... our depth should be -1'); # and our child count is 2 cmp_ok($parent_tree->getChildCount(), '==', 2, '... we have 2 children'); # now check our subtrees foreach my $sub_tree ($parent_tree->getAllChildren()) { # make sure they are not roots ok(!$sub_tree->isRoot(), '... the sub tree is not a root'); # and they are leaves ok($sub_tree->isLeaf(), '... but it is a leaf'); # and their parent is $parent_tree is($sub_tree->getParent(), $parent_tree, '... these should both be equal'); # and their depth is 0 cmp_ok($sub_tree->getDepth(), '==', 0, '... our depth should be 0'); # and that all their siblinds match # the children of their parent is_deeply( [ $parent_tree->getAllChildren() ], [ $sub_tree->getAllSiblings() ], '... the siblings are the same as the children'); } # now here comes the heart of this test # we now add in $tree (2.1) as a child # of the second child of the parent (2) $parent_tree->getChild(1)->addChild($tree); # now we verify that $tree no longer # thinks that its a root ok(!$tree->isRoot(), '... our tree is not longer a root'); # that $tree's depth has been # updated to reflect its new place # in the hierarchy (1) cmp_ok($tree->getDepth(), '==', 1, '... our depth should be 1'); # that $tree's parent is not shown to be # the second child of $parent_tree is($tree->getParent(), $parent_tree->getChild(1), '... these should both be equal'); # and now we check $tree's children foreach my $sub_tree ($tree->getAllChildren()) { # their depth should have been # updated to reflect their new # place in the hierarchy, so they # are now at a depth of 2 cmp_ok($sub_tree->getDepth(), '==', 2, '... our depth should be 2'); } # now we need to test what happens when we remove stuff my $removed = $parent_tree->getChild(1)->removeChild($tree); is($removed, $tree, '... we got the same tree'); # make sure its a root ok($removed->isRoot(), '... our tree is a root again'); # and it is not a leaf ok(!$removed->isLeaf(), '... and it is not a leaf'); # and that its depth is -1 cmp_ok($removed->getDepth(), '==', -1, '... our depth should be corrected to be -1'); # now check each subtree foreach my $sub_tree ($removed->getAllChildren()) { # their depth should be 0 now cmp_ok($sub_tree->getDepth(), '==', 0, '... our depth should be corrected to be 0'); } ## ---------------------------------------------------------------------------- ## end fixDepth Tests for Tree::Simple ## ---------------------------------------------------------------------------- Tree-Simple-1.29/t/13_Tree_Simple_clone_test.t0000644000175000017500000001353710715644075017355 0ustar ronron#!/usr/bin/perl use strict; use warnings; use Test::More tests => 48; ## ---------------------------------------------------------------------------- # NOTE: # This specifically tests the details of the cloning functions ## ---------------------------------------------------------------------------- use Tree::Simple; my $tree = Tree::Simple->new(Tree::Simple->ROOT); isa_ok($tree, 'Tree::Simple'); my $test = "test"; my $SCALAR_REF = \$test; my $REF_TO_REF = \$SCALAR_REF; my $ARRAY_REF = [ 1, 2, 3, 4 ]; my $HASH_REF = { one => 1, two => 2 }; my $CODE_REF = sub { "code ref test" }; my $REGEX_REF = qr/^reg-ex ref/; my $SUB_TREE = Tree::Simple->new("sub tree test"); my $MISC_OBJECT = bless({}, "Misc"); $tree->addChildren( Tree::Simple->new("non-ref"), Tree::Simple->new($SCALAR_REF), Tree::Simple->new($ARRAY_REF), Tree::Simple->new($HASH_REF), Tree::Simple->new($CODE_REF), Tree::Simple->new($REGEX_REF), Tree::Simple->new($MISC_OBJECT), Tree::Simple->new($SUB_TREE), Tree::Simple->new($REF_TO_REF) ); my $clone = $tree->clone(); isa_ok($clone, 'Tree::Simple'); # make sure all the parentage is correct is($clone->getParent(), Tree::Simple->ROOT, '... the clones parent is a root'); for my $child ($clone->getAllChildren()) { is($child->getParent(), $clone, '... the clones childrens parent should be our clone'); } isnt($clone, $tree, '... these should be refs'); is($clone->getChild(0)->getNodeValue(), $tree->getChild(0)->getNodeValue(), '... these should be the same value'); # they should both be scalar refs is(ref($clone->getChild(1)->getNodeValue()), "SCALAR", '... these should be scalar refs'); is(ref($tree->getChild(1)->getNodeValue()), "SCALAR", '... these should be scalar refs'); # but different ones isnt($clone->getChild(1)->getNodeValue(), $tree->getChild(1)->getNodeValue(), '... these should be different scalar refs'); # with the same value is(${$clone->getChild(1)->getNodeValue()}, ${$tree->getChild(1)->getNodeValue()}, '... these should be the same value'); # they should both be array refs is(ref($clone->getChild(2)->getNodeValue()), "ARRAY", '... these should be array refs'); is(ref($tree->getChild(2)->getNodeValue()), "ARRAY", '... these should be array refs'); # but different ones isnt($clone->getChild(2)->getNodeValue(), $tree->getChild(2)->getNodeValue(), '... these should be different array refs'); # with the same value is_deeply( $clone->getChild(2)->getNodeValue(), $tree->getChild(2)->getNodeValue(), '... these should have the same contents'); # they should both be hash refs is(ref($clone->getChild(3)->getNodeValue()), "HASH", '... these should be hash refs'); is(ref($tree->getChild(3)->getNodeValue()), "HASH", '... these should be hash refs'); # but different ones isnt($clone->getChild(3)->getNodeValue(), $tree->getChild(3)->getNodeValue(), '... these should be different hash refs'); # with the same value is_deeply( $clone->getChild(3)->getNodeValue(), $tree->getChild(3)->getNodeValue(), '... these should have the same contents'); # they should both be code refs is(ref($clone->getChild(4)->getNodeValue()), "CODE", '... these should be code refs'); is(ref($tree->getChild(4)->getNodeValue()), "CODE", '... these should be code refs'); # and still the same is($clone->getChild(4)->getNodeValue(), $tree->getChild(4)->getNodeValue(), '... these should be the same code refs'); is($clone->getChild(4)->getNodeValue()->(), $CODE_REF->(), '... this is equal'); # they should both be reg-ex refs is(ref($clone->getChild(5)->getNodeValue()), "Regexp", '... these should be reg-ex refs'); is(ref($tree->getChild(5)->getNodeValue()), "Regexp", '... these should be reg-ex refs'); # and still the same is($clone->getChild(5)->getNodeValue(), $tree->getChild(5)->getNodeValue(), '... these should be the same reg-ex refs'); # they should both be misc object refs is(ref($clone->getChild(6)->getNodeValue()), "Misc", '... these should be misc object refs'); is(ref($tree->getChild(6)->getNodeValue()), "Misc", '... these should be misc object refs'); # and still the same is($clone->getChild(6)->getNodeValue(), $tree->getChild(6)->getNodeValue(), '... these should be the same misc object refs'); # they should both be Tree::Simple objects is(ref($clone->getChild(7)->getNodeValue()), "Tree::Simple", '... these should be Tree::Simple'); is(ref($tree->getChild(7)->getNodeValue()), "Tree::Simple", '... these should be Tree::Simple'); # but different ones isnt($clone->getChild(7)->getNodeValue(), $tree->getChild(7)->getNodeValue(), '... these should be different Tree::Simple objects'); # with the same value is($clone->getChild(7)->getNodeValue()->getNodeValue(), $tree->getChild(7)->getNodeValue()->getNodeValue(), '... these should have the same contents'); # they should both be scalar refs is(ref($clone->getChild(8)->getNodeValue()), "REF", '... these should be refs of refs'); is(ref($tree->getChild(8)->getNodeValue()), "REF", '... these should be refs of refs'); # but different ones isnt($clone->getChild(8)->getNodeValue(), $tree->getChild(8)->getNodeValue(), '... these should be different scalar refs'); # with the same ref value is(${${$clone->getChild(8)->getNodeValue()}}, ${${$tree->getChild(8)->getNodeValue()}}, '... these should be the same value'); # test cloneShallow my $shallow_clone = $tree->cloneShallow(); isnt($shallow_clone, $tree, '... these should be refs'); is_deeply( [ $shallow_clone->getAllChildren() ], [ $tree->getAllChildren() ], '... the children are the same'); my $sub_tree = $tree->getChild(7); my $sub_tree_clone = $sub_tree->cloneShallow(); # but different ones isnt($sub_tree_clone->getNodeValue(), $sub_tree->getNodeValue(), '... these should be different Tree::Simple objects'); # with the same value is($sub_tree_clone->getNodeValue()->getNodeValue(), $sub_tree->getNodeValue()->getNodeValue(), '... these should have the same contents'); Tree-Simple-1.29/t/16_Tree_Simple_width_test.t0000644000175000017500000001510610715644075017371 0ustar ronron#!/usr/bin/perl use strict; use warnings; use Test::More tests => 77; BEGIN { use_ok('Tree::Simple'); }; { # test height (with pictures) my $tree = Tree::Simple->new(); isa_ok($tree, 'Tree::Simple'); my $D = Tree::Simple->new('D'); isa_ok($D, 'Tree::Simple'); $tree->addChild($D); # | # cmp_ok($D->getWidth(), '==', 1, '... D has a width of 1'); my $E = Tree::Simple->new('E'); isa_ok($E, 'Tree::Simple'); $D->addChild($E); # | # # \ # cmp_ok($D->getWidth(), '==', 1, '... D has a width of 1'); cmp_ok($E->getWidth(), '==', 1, '... E has a width of 1'); my $F = Tree::Simple->new('F'); isa_ok($F, 'Tree::Simple'); $E->addChild($F); # | # # \ # # \ # cmp_ok($D->getWidth(), '==', 1, '... D has a width of 1'); cmp_ok($E->getWidth(), '==', 1, '... E has a width of 1'); cmp_ok($F->getWidth(), '==', 1, '... F has a width of 1'); my $C = Tree::Simple->new('C'); isa_ok($C, 'Tree::Simple'); $D->addChild($C); # | # # / \ # # \ # cmp_ok($D->getWidth(), '==', 2, '... D has a width of 2'); cmp_ok($E->getWidth(), '==', 1, '... E has a width of 1'); cmp_ok($F->getWidth(), '==', 1, '... F has a width of 1'); cmp_ok($C->getWidth(), '==', 1, '... C has a width of 1'); my $B = Tree::Simple->new('B'); isa_ok($B, 'Tree::Simple'); $D->addChild($B); # | # # / | \ # # \ # cmp_ok($D->getWidth(), '==', 3, '... D has a width of 3'); cmp_ok($E->getWidth(), '==', 1, '... E has a width of 1'); cmp_ok($F->getWidth(), '==', 1, '... F has a width of 1'); cmp_ok($C->getWidth(), '==', 1, '... C has a width of 1'); cmp_ok($B->getWidth(), '==', 1, '... B has a width of 1'); my $A = Tree::Simple->new('A'); isa_ok($A, 'Tree::Simple'); $E->addChild($A); # | # # / | \ # # / \ # cmp_ok($D->getWidth(), '==', 4, '... D has a width of 4'); cmp_ok($E->getWidth(), '==', 2, '... E has a width of 2'); cmp_ok($F->getWidth(), '==', 1, '... F has a width of 1'); cmp_ok($C->getWidth(), '==', 1, '... C has a width of 1'); cmp_ok($B->getWidth(), '==', 1, '... B has a width of 1'); cmp_ok($A->getWidth(), '==', 1, '... A has a width of 1'); my $G = Tree::Simple->new('G'); isa_ok($G, 'Tree::Simple'); $E->insertChild(1, $G); # | # # / | \ # # / | \ # cmp_ok($D->getWidth(), '==', 5, '... D has a width of 5'); cmp_ok($E->getWidth(), '==', 3, '... E has a width of 3'); cmp_ok($F->getWidth(), '==', 1, '... F has a width of 1'); cmp_ok($G->getWidth(), '==', 1, '... G has a width of 1'); cmp_ok($C->getWidth(), '==', 1, '... C has a width of 1'); cmp_ok($B->getWidth(), '==', 1, '... B has a width of 1'); cmp_ok($A->getWidth(), '==', 1, '... A has a width of 1'); my $H = Tree::Simple->new('H'); isa_ok($H, 'Tree::Simple'); $G->addChild($H); # | # # / | \ # # / | \ # # | # cmp_ok($D->getWidth(), '==', 5, '... D has a width of 5'); cmp_ok($E->getWidth(), '==', 3, '... E has a width of 3'); cmp_ok($F->getWidth(), '==', 1, '... F has a width of 1'); cmp_ok($G->getWidth(), '==', 1, '... G has a width of 1'); cmp_ok($H->getWidth(), '==', 1, '... H has a width of 1'); cmp_ok($C->getWidth(), '==', 1, '... C has a width of 1'); cmp_ok($B->getWidth(), '==', 1, '... B has a width of 1'); cmp_ok($A->getWidth(), '==', 1, '... A has a width of 1'); my $I = Tree::Simple->new('I'); isa_ok($I, 'Tree::Simple'); $G->addChild($I); # | # # / | \ # # / | \ # # | \ # cmp_ok($D->getWidth(), '==', 6, '... D has a width of 6'); cmp_ok($E->getWidth(), '==', 4, '... E has a width of 4'); cmp_ok($F->getWidth(), '==', 1, '... F has a width of 1'); cmp_ok($G->getWidth(), '==', 2, '... G has a width of 2'); cmp_ok($H->getWidth(), '==', 1, '... H has a width of 1'); cmp_ok($I->getWidth(), '==', 1, '... I has a width of 1'); cmp_ok($C->getWidth(), '==', 1, '... C has a width of 1'); cmp_ok($B->getWidth(), '==', 1, '... B has a width of 1'); cmp_ok($A->getWidth(), '==', 1, '... A has a width of 1'); ok($E->removeChild($A), '... removed A subtree from B tree'); # | # # / | \ # # | \ # # | \ # cmp_ok($D->getWidth(), '==', 5, '... D has a width of 5'); cmp_ok($E->getWidth(), '==', 3, '... E has a width of 3'); cmp_ok($F->getWidth(), '==', 1, '... F has a width of 1'); cmp_ok($G->getWidth(), '==', 2, '... G has a width of 2'); cmp_ok($H->getWidth(), '==', 1, '... H has a width of 1'); cmp_ok($C->getWidth(), '==', 1, '... C has a width of 2'); cmp_ok($B->getWidth(), '==', 1, '... B has a width of 1'); # and the removed tree is ok cmp_ok($A->getWidth(), '==', 1, '... A has a width of 1'); ok($D->removeChild($E), '... removed E subtree from D tree'); # | # # / | # cmp_ok($D->getWidth(), '==', 2, '... D has a width of 2'); cmp_ok($C->getWidth(), '==', 1, '... C has a width of 1'); cmp_ok($B->getWidth(), '==', 1, '... B has a width of 1'); # and the removed trees are ok cmp_ok($E->getWidth(), '==', 3, '... E has a width of 3'); cmp_ok($F->getWidth(), '==', 1, '... F has a width of 1'); cmp_ok($G->getWidth(), '==', 2, '... G has a width of 2'); cmp_ok($H->getWidth(), '==', 1, '... H has a width of 1'); ok($D->removeChild($C), '... removed C subtree from D tree'); # | # # / # cmp_ok($D->getWidth(), '==', 1, '... D has a width of 1'); cmp_ok($B->getWidth(), '==', 1, '... B has a width of 1'); # and the removed tree is ok cmp_ok($C->getWidth(), '==', 1, '... C has a width of 1'); } Tree-Simple-1.29/t/17_Tree_Simple_width_test.t0000644000175000017500000000107612220721733017361 0ustar ronron#!/usr/bin/perl use strict; use warnings; use Test::More tests => 3; BEGIN { use_ok('Tree::Simple'); }; # ------------------------- my $n0 = Tree::Simple->new("0"); my $n00= Tree::Simple->new("0"); my $n01= Tree::Simple->new("0"); my $n02= Tree::Simple->new("0"); my $n03= Tree::Simple->new("0"); $n0->addChild($n00); $n0->addChildren(($n01, $n02, $n03)); #diag 'Auto width: ', $n0->getWidth(); is($n0 -> getWidth, 4, 'Auto-calculated width is correct'); $n0->fixWidth(); #diag 'Fixed width: ', $n0->getWidth(); is($n0 -> getWidth, 4, 'Fixed width is correct'); Tree-Simple-1.29/t/12_Tree_Simple_exceptions_test.t0000644000175000017500000002672210715644075020435 0ustar ronron#!/usr/bin/perl use strict; use warnings; use Test::More tests => 52; use Test::Exception; ## ---------------------------------------------------------------------------- ## Exception Tests for Tree::Simple ## ---------------------------------------------------------------------------- use Tree::Simple; my $BAD_OBJECT = bless({}, "Fail"); my $TEST_SUB_TREE = Tree::Simple->new("test"); # ----------------------------------------------- # exceptions for new # ----------------------------------------------- # not giving a proper argument for parent throws_ok { Tree::Simple->new("test", 0); } qr/^Insufficient Arguments \:/, '... this should die'; # not giving a proper argument for parent throws_ok { Tree::Simple->new("test", []); } qr/^Insufficient Arguments \:/, '... this should die'; # not giving a proper argument for parent throws_ok { Tree::Simple->new("test", $BAD_OBJECT); } qr/^Insufficient Arguments \:/, '... this should die'; # ----------------------------------------------- my $tree = Tree::Simple->new(Tree::Simple->ROOT); # ----------------------------------------------- # exceptions for setNodeValue # ----------------------------------------------- # not giving an argument for setNodeValue throws_ok { $tree->setNodeValue(); } qr/^Insufficient Arguments \: must supply a value for node/, '... this should die'; # ----------------------------------------------- # exceptions for addChild # ----------------------------------------------- # not giving an argument for addChild throws_ok { $tree->addChild(); } qr/^Insufficient Arguments : no tree\(s\) to insert/, '... this should die'; # giving an bad argument for addChild throws_ok { $tree->addChild("fail"); } qr/^Insufficient Arguments \: Child must be a Tree\:\:Simple object/, '... this should die'; # giving an bad argument for addChild throws_ok { $tree->addChild([]); } qr/^Insufficient Arguments \: Child must be a Tree\:\:Simple object/, '... this should die'; # giving an bad object argument for addChild throws_ok { $tree->addChild($BAD_OBJECT); } qr/^Insufficient Arguments \: Child must be a Tree\:\:Simple object/, '... this should die'; # ----------------------------------------------- # exceptions for insertChild # ----------------------------------------------- # giving no index argument for insertChild throws_ok { $tree->insertChild(); } qr/^Insufficient Arguments \: Cannot insert child without index/, '... this should die'; # giving an out of bounds index argument for insertChild throws_ok { $tree->insertChild(5); } qr/^Index Out of Bounds \: got \(5\) expected no more than \(0\)/, '... this should die'; # giving an good index argument but no tree argument for insertChild throws_ok { $tree->insertChild(0); } qr/^Insufficient Arguments \: no tree\(s\) to insert/, '... this should die'; # giving an good index argument but an undefined tree argument for insertChild throws_ok { $tree->insertChild(0, undef); } qr/^Insufficient Arguments \: Child must be a Tree\:\:Simple object/, '... this should die'; # giving an good index argument but a non-object tree argument for insertChild throws_ok { $tree->insertChild(0, "Fail"); } qr/^Insufficient Arguments \: Child must be a Tree\:\:Simple object/, '... this should die'; # giving an good index argument but a non-object-ref tree argument for insertChild throws_ok { $tree->insertChild(0, []); } qr/^Insufficient Arguments \: Child must be a Tree\:\:Simple object/, '... this should die'; # giving an good index argument but a bad object tree argument for insertChild throws_ok { $tree->insertChild(0, $BAD_OBJECT); } qr/^Insufficient Arguments \: Child must be a Tree\:\:Simple object/, '... this should die'; # ----------------------------------------------- # exceptions for insertChildren # ----------------------------------------------- # NOTE: # even though insertChild and insertChildren are # implemented in the same function, it makes sense # to future-proof our tests by checking it anyway # this will help to save us the trouble later on # giving no index argument for insertChild throws_ok { $tree->insertChildren(); } qr/^Insufficient Arguments \: Cannot insert child without index/, '... this should die'; # giving an out of bounds index argument for insertChild throws_ok { $tree->insertChildren(5); } qr/^Index Out of Bounds \: got \(5\) expected no more than \(0\)/, '... this should die'; # giving an good index argument but no tree argument for insertChild throws_ok { $tree->insertChildren(0); } qr/^Insufficient Arguments \: no tree\(s\) to insert/, '... this should die'; # giving an good index argument but an undefined tree argument for insertChild throws_ok { $tree->insertChildren(0, undef); } qr/^Insufficient Arguments \: Child must be a Tree\:\:Simple object/, '... this should die'; # giving an good index argument but a non-object tree argument for insertChild throws_ok { $tree->insertChildren(0, "Fail"); } qr/^Insufficient Arguments \: Child must be a Tree\:\:Simple object/, '... this should die'; # giving an good index argument but a non-object-ref tree argument for insertChild throws_ok { $tree->insertChildren(0, []); } qr/^Insufficient Arguments \: Child must be a Tree\:\:Simple object/, '... this should die'; # giving an good index argument but a bad object tree argument for insertChild throws_ok { $tree->insertChildren(0, $BAD_OBJECT); } qr/^Insufficient Arguments \: Child must be a Tree\:\:Simple object/, '... this should die'; # ----------------------------------------------- # exceptions for removeChildAt # ----------------------------------------------- # giving no index argument for removeChildAt throws_ok { $tree->removeChildAt(); } qr/^Insufficient Arguments \: Cannot remove child without index/, '... this should die'; # attempt to remove a child when there are none throws_ok { $tree->removeChildAt(5); } qr/^Illegal Operation \: There are no children to remove/, '... this should die'; # add a child now $tree->addChild($TEST_SUB_TREE); # giving no index argument for removeChildAt throws_ok { $tree->removeChildAt(5); } qr/^Index Out of Bounds \: got \(5\) expected no more than \(1\)/, '... this should die'; is($tree->removeChildAt(0), $TEST_SUB_TREE, '... these should be the same'); # ----------------------------------------------- # exceptions for removeChild # ----------------------------------------------- # giving no index argument for removeChild throws_ok { $tree->removeChild(); } qr/^Insufficient Arguments \: /, '... this should die'; # giving bad ref argument throws_ok { $tree->removeChild([]); } qr/^Insufficient Arguments \: /, '... this should die'; # giving bad object argument throws_ok { $tree->removeChild($BAD_OBJECT); } qr/^Insufficient Arguments \: /, '... this should die'; # giving bad object argument throws_ok { $tree->removeChild($TEST_SUB_TREE); } qr/^Child Not Found \: /, '... this should die'; # ----------------------------------------------- # exceptions for *Sibling methods # ----------------------------------------------- # attempting to add sibling to root trees throws_ok { $tree->addSibling($TEST_SUB_TREE); } qr/^Insufficient Arguments \: cannot add a sibling to a ROOT tree/, '... this should die'; # attempting to add siblings to root trees throws_ok { $tree->addSiblings($TEST_SUB_TREE); } qr/^Insufficient Arguments \: cannot add siblings to a ROOT tree/, '... this should die'; # attempting to insert sibling to root trees throws_ok { $tree->insertSibling(0, $TEST_SUB_TREE); } qr/^Insufficient Arguments \: cannot insert sibling\(s\) to a ROOT tree/, '... this should die'; # attempting to insert sibling to root trees throws_ok { $tree->insertSiblings(0, $TEST_SUB_TREE); } qr/^Insufficient Arguments \: cannot insert sibling\(s\) to a ROOT tree/, '... this should die'; # ----------------------------------------------- # exceptions for getChild # ----------------------------------------------- # not giving an index to the getChild method throws_ok { $tree->getChild(); } qr/^Insufficient Arguments \: Cannot get child without index/, '... this should die'; # ----------------------------------------------- # exceptions for getSibling # ----------------------------------------------- # trying to get siblings of a root tree throws_ok { $tree->getSibling(); } qr/^Insufficient Arguments \: cannot get siblings from a ROOT tree/, '... this should die'; # trying to get siblings of a root tree throws_ok { $tree->getAllSiblings(); } qr/^Insufficient Arguments \: cannot get siblings from a ROOT tree/, '... this should die'; # ----------------------------------------------- # exceptions for traverse # ----------------------------------------------- # passing no args to traverse throws_ok { $tree->traverse(); } qr/^Insufficient Arguments \: Cannot traverse without traversal function/, '... this should die'; # passing non-ref arg to traverse throws_ok { $tree->traverse("Fail"); } qr/^Incorrect Object Type \: traversal function is not a function/, '... this should die'; # passing non-code-ref arg to traverse throws_ok { $tree->traverse($BAD_OBJECT); } qr/^Incorrect Object Type \: traversal function is not a function/, '... this should die'; # passing second non-ref arg to traverse throws_ok { $tree->traverse(sub {}, "Fail"); } qr/^Incorrect Object Type \: post traversal function is not a function/, '... this should die'; # passing second non-code-ref arg to traverse throws_ok { $tree->traverse(sub {}, $BAD_OBJECT); } qr/^Incorrect Object Type \: post traversal function is not a function/, '... this should die'; # ----------------------------------------------- # exceptions for accept # ----------------------------------------------- # passing no args to accept throws_ok { $tree->accept(); } qr/^Insufficient Arguments \: You must supply a valid Visitor object/, '... this should die'; # passing non-ref arg to accept throws_ok { $tree->accept("Fail"); } qr/^Insufficient Arguments \: You must supply a valid Visitor object/, '... this should die'; # passing non-object-ref arg to accept throws_ok { $tree->accept([]); } qr/^Insufficient Arguments \: You must supply a valid Visitor object/, '... this should die'; # passing non-Tree::Simple::Visitor arg to accept throws_ok { $tree->accept($BAD_OBJECT); } qr/^Insufficient Arguments \: You must supply a valid Visitor object/, '... this should die'; { package TestPackage; sub visit {} } # passing non-Tree::Simple::Visitor arg to accept lives_ok { $tree->accept(bless({}, "TestPackage")); } '... but, this should live'; # ----------------------------------------------- # exceptions for _setParent # ----------------------------------------------- # if no parent is given throws_ok { $tree->_setParent(); } qr/^Insufficient Arguments/, '... this should croak'; # if the parent that is given is not an object throws_ok { $tree->_setParent("Test"); } qr/^Insufficient Arguments/, '... this should croak'; # if the parent that is given is a ref but not an object throws_ok { $tree->_setParent([]); } qr/^Insufficient Arguments/, '... this should croak'; # and if the parent that is given is an object but # is not a Tree::Simple object throws_ok { $tree->_setParent($BAD_OBJECT); } qr/^Insufficient Arguments/, '... this should croak'; # ----------------------------------------------- # exceptions for setUID # ----------------------------------------------- throws_ok { $tree->setUID(); } qr/^Insufficient Arguments/, '... this should croak'; ## ---------------------------------------------------------------------------- ## end Exception Tests for Tree::Simple ## ---------------------------------------------------------------------------- Tree-Simple-1.29/t/10_Tree_Simple_test.t0000644000175000017500000007701212626434246016170 0ustar ronron#!/usr/bin/perl use strict; use warnings; use Test::More tests => 292; BEGIN { use_ok('Tree::Simple'); }; ## ---------------------------------------------------------------------------- ## Test for Tree::Simple ## ---------------------------------------------------------------------------- # NOTE: # This test checks the base functionality of the Tree::Simple object. The test # is so large because (at the moment) each test relies upon the tree created # by the previous tests. It is not the most efficient or sensible thing to do # i know, but its how it is for now. There are close to 300 tests here, so # splitting them up would be a chore. ## ---------------------------------------------------------------------------- # check that we have a constructor can_ok("Tree::Simple", 'new'); # and that our ROOT constant is properly defined can_ok("Tree::Simple", 'ROOT'); # make a root for our tree my $tree = Tree::Simple->new("root tree", Tree::Simple->ROOT); isa_ok($tree, 'Tree::Simple'); # test the interface can_ok($tree, '_init'); can_ok($tree, '_setParent'); can_ok($tree, 'isRoot'); can_ok($tree, 'isLeaf'); can_ok($tree, 'setNodeValue'); can_ok($tree, 'getNodeValue'); can_ok($tree, 'getDepth'); can_ok($tree, 'fixDepth'); can_ok($tree, 'getParent'); can_ok($tree, 'getChildCount'); can_ok($tree, 'addChild'); can_ok($tree, 'addChildren'); can_ok($tree, 'insertChild'); can_ok($tree, 'insertChildren'); can_ok($tree, 'removeChildAt'); can_ok($tree, 'removeChild'); can_ok($tree, 'getChild'); can_ok($tree, 'getAllChildren'); can_ok($tree, 'addSibling'); can_ok($tree, 'addSiblings'); can_ok($tree, 'insertSibling'); can_ok($tree, 'insertSiblings'); can_ok($tree, 'getSibling'); can_ok($tree, 'getAllSiblings'); can_ok($tree, 'traverse'); can_ok($tree, 'accept'); can_ok($tree, 'clone'); can_ok($tree, 'cloneShallow'); can_ok($tree, 'DESTROY'); # verfiy that it is a root ok($tree->isRoot()); # and since it has no children # it is also a leaf node ok($tree->isLeaf()); # check the value of the node, # it should be root is($tree->getNodeValue(), "root tree", '... this tree is a root'); # we have no children yet cmp_ok($tree->getChildCount(), '==', 0, '... we have no children yet'); # check the depth cmp_ok($tree->getDepth(), '==', -1, '... we have no depth yet'); # check the index cmp_ok($tree->getIndex(), '==', -1, '... root trees have no index'); can_ok($tree, 'getUID'); is($tree->getUID(), $tree->getUID(), '... UIDs match for the same object'); is("$tree", "Tree::Simple=HASH(" . $tree->getUID() . ")", '... our UID is derived from our hex address'); can_ok($tree, 'setUID'); $tree->setUID("This is our unique identifier"); is($tree->getUID(), 'This is our unique identifier', '... UIDs match what we have set it to'); isnt("$tree", "Tree::Simple=HASH(" . $tree->getUID() . ")", '... our UID is no longer derived from our hex address'); ## ---------------------------------------------------------------------------- ## testing adding children ## ---------------------------------------------------------------------------- # create a child my $sub_tree = Tree::Simple->new("1.0"); isa_ok($sub_tree, 'Tree::Simple'); # check the node value is($sub_tree->getNodeValue(), "1.0", '... this tree is 1.0'); # since we have not assigned a parent it # will still be considered a root ok($sub_tree->isRoot()); # and since it has no children # it is also a leaf node ok($sub_tree->isLeaf()); # now add the child to our root $tree->addChild($sub_tree); # tree is no longer a leaf node # now that we have a child ok(!$tree->isLeaf()); # now that we have assigned a parent it # will no longer be considered a root ok(!$sub_tree->isRoot()); # check the depth of the sub_tree cmp_ok($sub_tree->getDepth(), '==', 0, '... depth should be 0 now'); # check the index cmp_ok($sub_tree->getIndex(), '==', 0, '... index should be 0 now'); # check the child count, # it should be one now cmp_ok($tree->getChildCount(), '==', 1, '... we should have 1 children now'); # get the child we inserted # and compare it with sub_tree # they should be the same is($tree->getChild(0), $sub_tree, '... make sure our sub_tree is fetchable'); # get the parent of sub_tree my $sub_tree_parent = $sub_tree->getParent(); # now test that the parent of # our sub_tree is the same as # our root is($tree, $sub_tree_parent, '... make sure our sub_tree parent is tree'); ## ---------------------------------------------------------------------------- ## testing adding siblings ## ---------------------------------------------------------------------------- # create another sub_tree my $sub_tree_2 = Tree::Simple->new("2.0"); isa_ok($sub_tree_2, 'Tree::Simple'); # check its node value is($sub_tree_2->getNodeValue(), "2.0", '... this tree is 2.0'); # since we have not assigned a parent to # the new sub_tree it will still be # considered a root ok($sub_tree_2->isRoot()); # and since it has no children # it is also a leaf node ok($sub_tree_2->isLeaf()); # add our new subtree as a sibling # of our first sub_tree $sub_tree->addSibling($sub_tree_2); # now that we have assigned a parent to # the new sub_tree, it will no longer be # considered a root ok(!$sub_tree_2->isRoot()); # check the depth of the sub_tree cmp_ok($sub_tree_2->getDepth(), '==', 0, '... depth should be 0 now'); # check the index cmp_ok($sub_tree_2->getIndex(), '==', 1, '... index should be 1'); # make sure that we now have 2 children in our root cmp_ok($tree->getChildCount(), '==', 2, '... we should have 2 children now'); # and verify that the child at index 1 # is actually our second sub_tree is($tree->getChild(1), $sub_tree_2, '... make sure our sub_tree is fetchable'); # get the parent of our second sub_tree my $sub_tree_2_parent = $sub_tree_2->getParent(); # and make sure that it is the # same as our root is($tree, $sub_tree_2_parent, '... make sure our sub_tree_2 parent is tree'); ## ---------------------------------------------------------------------------- ## test adding child by giving parent as a constructor argument ## ---------------------------------------------------------------------------- # we create our new sub_tree and attach it # to our root through its constructor my $sub_tree_4 = Tree::Simple->new("4.0", $tree); # check its node value is($sub_tree_4->getNodeValue(), "4.0", '... this tree is 4.0'); # since we have assigned a parent to # the new sub_tree, it will no longer be # considered a root ok(!$sub_tree_4->isRoot()); # check the depth of the sub_tree cmp_ok($sub_tree_4->getDepth(), '==', 0, '... depth should be 0 now'); # check the index cmp_ok($sub_tree_4->getIndex(), '==', 2, '... index should be 2 now'); # but since it has no children # it is also a leaf node ok($sub_tree_4->isLeaf()); # make sure that we now have 3 children in our root cmp_ok($tree->getChildCount(), '==', 3, '... we should have 3 children now'); # and verify that the child at index 2 # is actually our latest sub_tree is($tree->getChild(2), $sub_tree_4, '... make sure our sub_tree is fetchable'); # and make sure that the new sub-trees # parent is the same as our root is($tree, $sub_tree_4->getParent(), '... make sure our sub_tree_4 parent is tree'); ## ---------------------------------------------------------------------------- ## test inserting child ## ---------------------------------------------------------------------------- # we create our new sub_tree my $sub_tree_3 = Tree::Simple->new("3.0"); # check its node value is($sub_tree_3->getNodeValue(), "3.0", '... this tree is 3.0'); # since we have not assigned a parent to # the new sub_tree it will still be # considered a root ok($sub_tree_3->isRoot()); # but since it has no children # it is also a leaf node ok($sub_tree_3->isLeaf()); # now insert the child at index 2 $tree->insertChild(2, $sub_tree_3); # since we now have assigned a parent to # the new sub_tree, it will no longer be # considered a root ok(!$sub_tree_3->isRoot()); # check the depth of the sub_tree cmp_ok($sub_tree_3->getDepth(), '==', 0, '... depth should be 0 now'); # check the index of 3 cmp_ok($sub_tree_3->getIndex(), '==', 2, '... index should be 2 now'); # check the index of 4 now cmp_ok($sub_tree_4->getIndex(), '==', 3, '... index should be 3 now'); # make sure that we now have 3 children in our root cmp_ok($tree->getChildCount(), '==', 4, '... we should have 4 children now'); # and verify that the child at index 2 # is actually our latest sub_tree is($tree->getChild(2), $sub_tree_3, '... make sure our sub_tree is fetchable'); # and verify that the child that was # at index 2 is actually now actually # at index 3 is($tree->getChild(3), $sub_tree_4, '... make sure our sub_tree is fetchable'); # and make sure that the new sub-trees # parent is the same as our root is($tree, $sub_tree_3->getParent(), '... make sure our sub_tree_3 parent is tree'); ## ---------------------------------------------------------------------------- ## test getting all children and siblings ## ---------------------------------------------------------------------------- # get it in scalar context and # check that our arrays are equal my $children = $tree->getAllChildren(); ok eq_array($children, [ $sub_tree, $sub_tree_2, $sub_tree_3, $sub_tree_4 ]); # get it in array context and # check that our arrays are equal my @children = $tree->getAllChildren(); ok eq_array(\@children, [ $sub_tree, $sub_tree_2, $sub_tree_3, $sub_tree_4 ]); # check that the values from both # contexts are equal to one another ok eq_array($children, \@children); # now check that the siblings of all the # sub_trees are the same as the children foreach my $_sub_tree (@children) { # test siblings in scalar context my $siblings = $sub_tree->getAllSiblings(); ok eq_array($children, $siblings); # and now in array context my @siblings = $sub_tree->getAllSiblings(); ok eq_array($children, \@siblings); } ## ---------------------------------------------------------------------------- ## test addChildren ## ---------------------------------------------------------------------------- my @sub_children = ( Tree::Simple->new("1.1"), Tree::Simple->new("1.5"), Tree::Simple->new("1.6") ); # now go through the children and test them foreach my $sub_child (@sub_children) { # they should think they are root ok($sub_child->isRoot()); # and they should all be leaves ok($sub_child->isLeaf()); # and their node values like($sub_child->getNodeValue(), qr/1\.[0-9]/, '... they at least have "1." followed by a digit'); # and they should all have a depth of -1 cmp_ok($sub_child->getDepth(), '==', -1, '... depth should be -1'); } # check to see if we can add children $sub_tree->addChildren(@sub_children); # we are no longer a leaf node now ok(!$sub_tree->isLeaf()); # make sure that we now have 3 children now cmp_ok($sub_tree->getChildCount(), '==', 3, '... we should have 3 children now'); # now check that sub_tree's children # are the same as our list ok eq_array([ $sub_tree->getAllChildren() ], \@sub_children); # now go through the children again # and test them foreach my $sub_child (@sub_children) { # they should no longer think # they are root ok(!$sub_child->isRoot()); # but they should still think they # are leaves ok($sub_child->isLeaf()); # now we test their parental relationship is($sub_tree, $sub_child->getParent(), '... their parent is the sub_tree'); # and they should all have a depth of 1 cmp_ok($sub_child->getDepth(), '==', 1, '... depth should be 1'); # now check that its siblings are the same # as the children of its parent ok eq_array([ $sub_tree->getAllChildren() ], [ $sub_child->getAllSiblings() ]); } ## ---------------------------------------------------------------------------- ## test insertingChildren ## ---------------------------------------------------------------------------- my @more_sub_children = ( Tree::Simple->new("1.2"), Tree::Simple->new("1.3"), Tree::Simple->new("1.4") ); # now go through the children and test them foreach my $sub_child (@more_sub_children) { # they should think they are root ok($sub_child->isRoot()); # and they should all be leaves ok($sub_child->isLeaf()); # and their node values like($sub_child->getNodeValue(), qr/1\.[0-9]/, '... they at least have "1." followed by a digit'); # and they should all have a depth of -1 cmp_ok($sub_child->getDepth(), '==', -1, '... depth should be -1'); } # check to see if we can insert children $sub_tree->insertChildren(1, @more_sub_children); # make sure that we now have 6 children now cmp_ok($sub_tree->getChildCount(), '==', 6, '... we should have 6 children now'); # now check that sub_tree's children # are the same as our list ok eq_array([ $sub_tree->getAllChildren() ], [ $sub_children[0], @more_sub_children, @sub_children[1 .. $#sub_children] ]); # now go through the children again # and test them foreach my $sub_child (@more_sub_children) { # they should no longer think # they are roots ok(!$sub_child->isRoot()); # but they should still think they # are leaves ok($sub_child->isLeaf()); # now we test their parental relationship is($sub_tree, $sub_child->getParent(), '... their parent is the sub_tree'); # and they should all have a depth of 1 cmp_ok($sub_child->getDepth(), '==', 1, '... depth should be 1'); # now check that its siblings are the same # as the children of its parent ok eq_array([ $sub_tree->getAllChildren() ], [ $sub_child->getAllSiblings() ]); } ## ---------------------------------------------------------------------------- ## test addingSiblings ## ---------------------------------------------------------------------------- my @more_children = ( Tree::Simple->new("5.0"), Tree::Simple->new("9.0") ); # now go through the children and test them foreach my $sub_child (@more_children) { # they should think they are root ok($sub_child->isRoot()); # and they should all be leaves ok($sub_child->isLeaf()); # and their node values like($sub_child->getNodeValue(), qr/[0-9]\.0/, '... they at least have digit followed by ".0"'); # and they should all have a depth of -1 cmp_ok($sub_child->getDepth(), '==', -1, '... depth should be -1'); } # check to see if we can insert children $sub_tree->addSiblings(@more_children); # make sure that we now have 6 children now cmp_ok($tree->getChildCount(), '==', 6, '... we should have 6 children now'); # now check that tree's new children # are the same as our list is($tree->getChild(4), $more_children[0], '... they are the same'); is($tree->getChild(5), $more_children[1], '... they are the same'); # now go through the children again # and test them foreach my $sub_child (@more_children) { # they should no longer think # they are roots ok(!$sub_child->isRoot()); # but they should still think they # are leaves ok($sub_child->isLeaf()); # now we test their parental relationship is($tree, $sub_child->getParent(), '... their parent is the tree'); # and they should all have a depth of 1 cmp_ok($sub_child->getDepth(), '==', 0, '... depth should be 0'); # now check that its siblings are the same # as the children of its parent ok eq_array([ $tree->getAllChildren() ], [ $sub_child->getAllSiblings() ]); } ## ---------------------------------------------------------------------------- ## test insertSibling ## ---------------------------------------------------------------------------- my $new_sibling = Tree::Simple->new("8.0"); # they should think they are root ok($new_sibling->isRoot()); # and they should all be leaves ok($new_sibling->isLeaf()); # and their node values is($new_sibling->getNodeValue(), "8.0", '... node value should be 6.0'); # and they should all have a depth of -1 cmp_ok($new_sibling->getDepth(), '==', -1, '... depth should be -1'); # check to see if we can insert children $sub_tree->insertSibling(5, $new_sibling); # make sure that we now have 6 children now cmp_ok($tree->getChildCount(), '==', 7, '... we should have 7 children now'); # now check that sub_tree's new sibling # is in the right place and that it # should have displaced the old value at # that index to index + 1 is($tree->getChild(4), $more_children[0], '... they are the same'); is($tree->getChild(5), $new_sibling, '... they are the same'); is($tree->getChild(6), $more_children[1], '... they are the same'); # they should no longer think # they are roots ok(!$new_sibling->isRoot()); # but they should still think they # are leaves ok($new_sibling->isLeaf()); # now we test their parental relationship is($tree, $new_sibling->getParent(), '... their parent is the tree'); # and they should all have a depth of 1 cmp_ok($new_sibling->getDepth(), '==', 0, '... depth should be 0'); # now check that its siblings are the same # as the children of its parent ok eq_array([ $tree->getAllChildren() ], [ $new_sibling->getAllSiblings() ]); ## ---------------------------------------------------------------------------- ## test inserting Siblings ## ---------------------------------------------------------------------------- my @even_more_children = ( Tree::Simple->new("6.0"), Tree::Simple->new("7.0") ); # now go through the children and test them foreach my $sub_child (@even_more_children) { # they should think they are root ok($sub_child->isRoot()); # and they should all be leaves ok($sub_child->isLeaf()); # and their node values like($sub_child->getNodeValue(), qr/[0-9]\.0/, '... they at least have digit followed by ".0"'); # and they should all have a depth of -1 cmp_ok($sub_child->getDepth(), '==', -1, '... depth should be -1'); } # check to see if we can insert children $sub_tree->insertSiblings(5, @even_more_children); # make sure that we now have 6 children now cmp_ok($tree->getChildCount(), '==', 9, '... we should have 6 children now'); # now check that tree's new children # are the same as our list is($tree->getChild(4), $more_children[0], '... they are the same'); is($tree->getChild(5), $even_more_children[0], '... they are the same'); is($tree->getChild(6), $even_more_children[1], '... they are the same'); is($tree->getChild(7), $new_sibling, '... they are the same'); is($tree->getChild(8), $more_children[1], '... they are the same'); # now go through the children again # and test them foreach my $sub_child (@even_more_children) { # they should no longer think # they are roots ok(!$sub_child->isRoot()); # but they should still think they # are leaves ok($sub_child->isLeaf()); # now we test their parental relationship is($tree, $sub_child->getParent(), '... their parent is the tree'); # and they should all have a depth of 1 cmp_ok($sub_child->getDepth(), '==', 0, '... depth should be 0'); # now check that its siblings are the same # as the children of its parent ok eq_array([ $tree->getAllChildren() ], [ $sub_child->getAllSiblings() ]); } ## ---------------------------------------------------------------------------- ## test getChild and getSibling ## ---------------------------------------------------------------------------- # make sure that getChild returns the # same as getSibling is($tree->getChild($_), $sub_tree->getSibling($_), '... siblings are the same as children') foreach (0 .. $tree->getChildCount()); ## ---------------------------------------------------------------------------- ## test self referential returns ## ---------------------------------------------------------------------------- # addChildren's return value is actually $self # so that method calls can be chained my $self_ref_tree_test = Tree::Simple->new("3.1", $sub_tree_3) ->addChildren( Tree::Simple->new("3.1.1"), Tree::Simple->new("3.1.2") ); # make sure that it true isa_ok($self_ref_tree_test, 'Tree::Simple'); # it shouldnt be a root ok(!$self_ref_tree_test->isRoot()); # and it shouldnt be a leaf ok(!$self_ref_tree_test->isLeaf()); # make sure that the parent in the constructor worked is($sub_tree_3, $self_ref_tree_test->getParent(), '... should be the same'); # and the parents count should be 1 cmp_ok($sub_tree_3->getChildCount(), '==', 1, '... we should have 1 child here'); # make sure they show up in the count test cmp_ok($self_ref_tree_test->getChildCount(), '==', 2, '... we should have 2 children here'); foreach my $sub_child ($self_ref_tree_test->getAllChildren()) { # they should not think # they are roots ok(!$sub_child->isRoot()); # but they should think they # are leaves ok($sub_child->isLeaf()); # now we test their parental relationship is($self_ref_tree_test, $sub_child->getParent(), '... their parent is the tree'); # and they should all have a depth of 1 cmp_ok($sub_child->getDepth(), '==', 2, '... depth should be 0'); # now check that its siblings are the same # as the children of its parent ok eq_array([ $self_ref_tree_test->getAllChildren() ], [ $sub_child->getAllSiblings() ]); } ## ---------------------------------------------------------------------------- ## Test self-referential version of addChild ## ---------------------------------------------------------------------------- # addChild's return value is actually $self # so that method calls can be chained my $self_ref_tree_test_2 = Tree::Simple->new("2.1", $sub_tree_2) ->addChild( Tree::Simple->new("2.1.1") ); # make sure that it true isa_ok($self_ref_tree_test_2, 'Tree::Simple'); # it shouldnt be a root ok(!$self_ref_tree_test_2->isRoot()); # and it shouldnt be a leaf ok(!$self_ref_tree_test_2->isLeaf()); # make sure that the parent in the constructor worked is($sub_tree_2, $self_ref_tree_test_2->getParent(), '... should be the same'); # and the parents count should be 1 cmp_ok($sub_tree_2->getChildCount(), '==', 1, '... we should have 1 child here'); # make sure they show up in the count test cmp_ok($self_ref_tree_test_2->getChildCount(), '==', 1, '... we should have 1 child here'); my $sub_child = $self_ref_tree_test_2->getChild(0); # they should not think # they are roots ok(!$sub_child->isRoot()); # but they should think they # are leaves ok($sub_child->isLeaf()); # now we test their parental relationship is($self_ref_tree_test_2, $sub_child->getParent(), '... their parent is the tree'); # and they should all have a depth of 1 cmp_ok($sub_child->getDepth(), '==', 2, '... depth should be 0'); # now check that its siblings are the same # as the children of its parent ok eq_array([ $self_ref_tree_test_2->getAllChildren() ], [ $sub_child->getAllSiblings() ]); ## ---------------------------------------------------------------------------- ## test removeChildAt ## ---------------------------------------------------------------------------- my $sub_tree_of_tree_to_remove = Tree::Simple->new("1.1.a.1"); # make a node to remove my $tree_to_remove = Tree::Simple->new("1.1.a")->addChild($sub_tree_of_tree_to_remove); # test that its a root ok($tree_to_remove->isRoot()); # and that its depth is -1 cmp_ok($tree_to_remove->getDepth(), '==', -1, '... the depth should be -1'); # and the sub-trees depth is 0 cmp_ok($sub_tree_of_tree_to_remove->getDepth(), '==', 0, '... the depth should be 0'); # insert it into the sub_tree $sub_tree->insertChild(1, $tree_to_remove); # test that it no longer thinks its a root ok(!$tree_to_remove->isRoot()); # check thats its depth is now 1 cmp_ok($tree_to_remove->getDepth(), '==', 1, '... the depth should be 1'); # and the sub-trees depth is 2 cmp_ok($sub_tree_of_tree_to_remove->getDepth(), '==', 2, '... the depth should be 2'); # make sure it is there is($sub_tree->getChild(1), $tree_to_remove, '... these tree should be equal'); # remove the subtree (it will be returned) my $removed_tree = $sub_tree->removeChildAt(1); # now check that the one removed it the one # we inserted origianlly is($removed_tree, $tree_to_remove, '... these tree should be equal'); # it should think its a root again ok($tree_to_remove->isRoot()); # and its depth should be back to -1 cmp_ok($tree_to_remove->getDepth(), '==', -1, '... the depth should be -1'); # and the sub-trees depth is 0 cmp_ok($sub_tree_of_tree_to_remove->getDepth(), '==', 0, '... the depth should be 0'); ## ---------------------------------------------------------------------------- ## test removeChild ## ---------------------------------------------------------------------------- my $sub_tree_of_tree_to_remove2 = Tree::Simple->new("1.1.a.1"); # make a node to remove my $tree_to_remove2 = Tree::Simple->new("1.1.a")->addChild($sub_tree_of_tree_to_remove2); # test that its a root ok($tree_to_remove2->isRoot()); # and that its depth is -1 cmp_ok($tree_to_remove2->getDepth(), '==', -1, '... the depth should be -1'); # and the sub-trees depth is 0 cmp_ok($sub_tree_of_tree_to_remove2->getDepth(), '==', 0, '... the depth should be 0'); # insert it into the sub_tree $sub_tree->insertChild(1, $tree_to_remove2); # test that it no longer thinks its a root ok(!$tree_to_remove2->isRoot()); # check thats its depth is now 1 cmp_ok($tree_to_remove2->getDepth(), '==', 1, '... the depth should be 1'); # and the sub-trees depth is 2 cmp_ok($sub_tree_of_tree_to_remove2->getDepth(), '==', 2, '... the depth should be 2'); # make sure it is there is($sub_tree->getChild(1), $tree_to_remove2, '... these tree should be equal'); # remove the subtree (it will be returned) my $removed_tree2 = $sub_tree->removeChild($tree_to_remove2); # now check that the one removed it the one # we inserted origianlly is($removed_tree2, $tree_to_remove2, '... these tree should be equal'); # it should think its a root again ok($tree_to_remove2->isRoot()); # and its depth should be back to -1 cmp_ok($tree_to_remove2->getDepth(), '==', -1, '... the depth should be -1'); # and the sub-trees depth is 0 cmp_ok($sub_tree_of_tree_to_remove2->getDepth(), '==', 0, '... the depth should be 0'); ## ---------------------------------------------------------------------------- ## test removeChild backwards compatibility ## ---------------------------------------------------------------------------- # make a node to remove my $tree_to_remove3 = Tree::Simple->new("1.1.a"); # test that its a root ok($tree_to_remove3->isRoot()); # and that its depth is -1 cmp_ok($tree_to_remove3->getDepth(), '==', -1, '... the depth should be -1'); # insert it into the sub_tree $sub_tree->insertChild(1, $tree_to_remove3); # test that it no longer thinks its a root ok(!$tree_to_remove3->isRoot()); # check thats its depth is now 1 cmp_ok($tree_to_remove3->getDepth(), '==', 1, '... the depth should be 1'); # make sure it is there is($sub_tree->getChild(1), $tree_to_remove3, '... these tree should be equal'); # remove the subtree (it will be returned) my $removed_tree3 = $sub_tree->removeChild(1); # now check that the one removed it the one # we inserted origianlly is($removed_tree3, $tree_to_remove3, '... these tree should be equal'); # it should think its a root again ok($tree_to_remove3->isRoot()); # and its depth should be back to -1 cmp_ok($tree_to_remove3->getDepth(), '==', -1, '... the depth should be -1'); ## ---------------------------------------------- ## now test the edge cases ## ---------------------------------------------- # trees at the end # make a node to remove my $tree_to_remove_2 = Tree::Simple->new("1.7"); # add it into the sub_tree $sub_tree->addChild($tree_to_remove_2); # make sure it is there is($sub_tree->getChild($sub_tree->getChildCount() - 1), $tree_to_remove_2, '... these tree should be equal'); # remove the subtree (it will be returned) my $removed_tree_2 = $sub_tree->removeChildAt($sub_tree->getChildCount() - 1); # now check that the one removed it the one # we inserted origianlly is($removed_tree_2, $tree_to_remove_2, '... these tree should be equal'); # trees at the beginging # make a node to remove my $tree_to_remove_3 = Tree::Simple->new("1.1.-1"); # add it into the sub_tree $sub_tree->insertChild(0, $tree_to_remove_3); # make sure it is there is($sub_tree->getChild(0), $tree_to_remove_3, '... these tree should be equal'); # remove the subtree (it will be returned) my $removed_tree_3 = $sub_tree->removeChildAt(0); # now check that the one removed it the one # we inserted origianlly is($removed_tree_3, $tree_to_remove_3, '... these tree should be equal'); ## ---------------------------------------------------------------------------- ## test traverse ## ---------------------------------------------------------------------------- # make a control set of # all the nodes we have my @_all_node_values = qw( 1.0 1.1 1.2 1.3 1.4 1.5 1.6 2.0 2.1 2.1.1 3.0 3.1 3.1.1 3.1.2 4.0 5.0 6.0 7.0 8.0 9.0 ); my @all_node_values; # now collect the nodes in the actual tree $tree->traverse(sub { my ($_tree) = @_; push @all_node_values => $_tree->getNodeValue(); }); # and compare the two is_deeply(\@_all_node_values, \@all_node_values, '... our nodes match our control nodes'); # test traverse with both pre- and post- methods # make a control set of # all the nodes we have with XML-style my @_all_node_values_post_traverse = qw( 1.0 1.1 1.1 1.2 1.2 1.3 1.3 1.4 1.4 1.5 1.5 1.6 1.6 1.0 2.0 2.1 2.1.1 2.1.1 2.1 2.0 3.0 3.1 3.1.1 3.1.1 3.1.2 3.1.2 3.1 3.0 4.0 4.0 5.0 5.0 6.0 6.0 7.0 7.0 8.0 8.0 9.0 9.0 ); my @all_node_values_post_traverse; # now collect the nodes in the actual tree $tree->traverse(sub { my ($_tree) = @_; push @all_node_values_post_traverse => $_tree->getNodeValue(); }, sub { my ($_tree) = @_; push @all_node_values_post_traverse => $_tree->getNodeValue(); } ); # and compare the two is_deeply(\@_all_node_values_post_traverse, \@all_node_values_post_traverse, '... our nodes match our control nodes for post traverse method'); ## ---------------------------------------------------------------------------- ## test size ## ---------------------------------------------------------------------------- cmp_ok($tree->size(), '==', (scalar(@_all_node_values) + 1), '... our size is as we expect it to be'); # NOTE: # it is (scalar(@_all_node_values) + 1) so that # we account for the root node which is not in # the list. ## ---------------------------------------------------------------------------- ## test height ## ---------------------------------------------------------------------------- cmp_ok($tree->height(), '==', 4, '... our height is as we expect it to be'); ## ---------------------------------------------------------------------------- ## test clone ## ---------------------------------------------------------------------------- # clone the whole tree my $tree_clone = $tree->clone(); my @all_cloned_node_values; # collect all the cloned values $tree_clone->traverse(sub { my ($_tree) = @_; push @all_cloned_node_values => $_tree->getNodeValue(); }); # make sure that our cloned values equal to our control ok eq_array(\@_all_node_values, \@all_cloned_node_values); # and make sure they also match the original tree ok eq_array(\@all_node_values, \@all_cloned_node_values); # now change all the node values $tree_clone->traverse(sub { my ($_tree) = @_; $_tree->setNodeValue("-> " . $_tree->getNodeValue()); }); my @all_cloned_node_values_changed; # collect them again $tree_clone->traverse(sub { my ($_tree) = @_; push @all_cloned_node_values_changed => $_tree->getNodeValue(); }); # make a copy of our control and cange it too my @_all_node_values_changed = map { "-> $_" } @_all_node_values; # now both our changed values should be correct ok eq_array(\@_all_node_values_changed, \@all_cloned_node_values_changed); my @all_node_values_check; # now traverse the original tree again and make sure # that the nodes are not changed $tree->traverse(sub { my ($_tree) = @_; push @all_node_values_check => $_tree->getNodeValue(); }); # this can be accomplished by checking them # against our control again ok eq_array(\@_all_node_values, \@all_node_values_check); ## ---------------------------------------------------------------------------- ## end test for Tree::Simple ## ---------------------------------------------------------------------------- Tree-Simple-1.29/t/15_Tree_Simple_height_test.t0000644000175000017500000001351710715644075017525 0ustar ronron#!/usr/bin/perl use strict; use warnings; use Test::More tests => 67; BEGIN { use_ok('Tree::Simple'); }; { # test height (with pictures) my $tree = Tree::Simple->new(); isa_ok($tree, 'Tree::Simple'); my $D = Tree::Simple->new('D'); isa_ok($D, 'Tree::Simple'); $tree->addChild($D); # | # cmp_ok($D->getHeight(), '==', 1, '... D has a height of 1'); my $E = Tree::Simple->new('E'); isa_ok($E, 'Tree::Simple'); $D->addChild($E); # | # # \ # cmp_ok($D->getHeight(), '==', 2, '... D has a height of 2'); cmp_ok($E->getHeight(), '==', 1, '... E has a height of 1'); my $F = Tree::Simple->new('F'); isa_ok($F, 'Tree::Simple'); $E->addChild($F); # | # # \ # # \ # cmp_ok($D->getHeight(), '==', 3, '... D has a height of 3'); cmp_ok($E->getHeight(), '==', 2, '... E has a height of 2'); cmp_ok($F->getHeight(), '==', 1, '... F has a height of 1'); my $C = Tree::Simple->new('C'); isa_ok($C, 'Tree::Simple'); $D->addChild($C); # | # # / \ # # \ # cmp_ok($D->getHeight(), '==', 3, '... D has a height of 3'); cmp_ok($E->getHeight(), '==', 2, '... E has a height of 2'); cmp_ok($F->getHeight(), '==', 1, '... F has a height of 1'); cmp_ok($C->getHeight(), '==', 1, '... C has a height of 1'); my $B = Tree::Simple->new('B'); isa_ok($B, 'Tree::Simple'); $C->addChild($B); # | # # / \ # # / \ # cmp_ok($D->getHeight(), '==', 3, '... D has a height of 3'); cmp_ok($E->getHeight(), '==', 2, '... E has a height of 2'); cmp_ok($F->getHeight(), '==', 1, '... F has a height of 1'); cmp_ok($C->getHeight(), '==', 2, '... C has a height of 2'); cmp_ok($B->getHeight(), '==', 1, '... B has a height of 1'); my $A = Tree::Simple->new('A'); isa_ok($A, 'Tree::Simple'); $B->addChild($A); # | # # / \ # # / \ # # / # cmp_ok($D->getHeight(), '==', 4, '... D has a height of 4'); cmp_ok($E->getHeight(), '==', 2, '... E has a height of 2'); cmp_ok($F->getHeight(), '==', 1, '... F has a height of 1'); cmp_ok($C->getHeight(), '==', 3, '... C has a height of 3'); cmp_ok($B->getHeight(), '==', 2, '... B has a height of 2'); cmp_ok($A->getHeight(), '==', 1, '... A has a height of 1'); my $G = Tree::Simple->new('G'); isa_ok($G, 'Tree::Simple'); $E->insertChild(0, $G); # | # # / \ # # / / \ # # / # cmp_ok($D->getHeight(), '==', 4, '... D has a height of 4'); cmp_ok($E->getHeight(), '==', 2, '... E has a height of 2'); cmp_ok($F->getHeight(), '==', 1, '... F has a height of 1'); cmp_ok($G->getHeight(), '==', 1, '... G has a height of 1'); cmp_ok($C->getHeight(), '==', 3, '... C has a height of 3'); cmp_ok($B->getHeight(), '==', 2, '... B has a height of 2'); cmp_ok($A->getHeight(), '==', 1, '... A has a height of 1'); my $H = Tree::Simple->new('H'); isa_ok($H, 'Tree::Simple'); $G->addChild($H); # | # # / \ # # / / \ # # / \ # cmp_ok($D->getHeight(), '==', 4, '... D has a height of 4'); cmp_ok($E->getHeight(), '==', 3, '... E has a height of 3'); cmp_ok($F->getHeight(), '==', 1, '... F has a height of 1'); cmp_ok($G->getHeight(), '==', 2, '... G has a height of 2'); cmp_ok($H->getHeight(), '==', 1, '... H has a height of 1'); cmp_ok($C->getHeight(), '==', 3, '... C has a height of 3'); cmp_ok($B->getHeight(), '==', 2, '... B has a height of 2'); cmp_ok($A->getHeight(), '==', 1, '... A has a height of 1'); ok($B->removeChild($A), '... removed A subtree from B tree'); # | # # / \ # # / / \ # # \ # cmp_ok($D->getHeight(), '==', 4, '... D has a height of 4'); cmp_ok($E->getHeight(), '==', 3, '... E has a height of 3'); cmp_ok($F->getHeight(), '==', 1, '... F has a height of 1'); cmp_ok($G->getHeight(), '==', 2, '... G has a height of 2'); cmp_ok($H->getHeight(), '==', 1, '... H has a height of 1'); cmp_ok($C->getHeight(), '==', 2, '... C has a height of 2'); cmp_ok($B->getHeight(), '==', 1, '... B has a height of 1'); # and the removed tree is ok cmp_ok($A->getHeight(), '==', 1, '... A has a height of 1'); ok($D->removeChild($E), '... removed E subtree from D tree'); # | # # / # # / # cmp_ok($D->getHeight(), '==', 3, '... D has a height of 3'); cmp_ok($C->getHeight(), '==', 2, '... C has a height of 2'); cmp_ok($B->getHeight(), '==', 1, '... B has a height of 1'); # and the removed trees are ok cmp_ok($E->getHeight(), '==', 3, '... E has a height of 3'); cmp_ok($F->getHeight(), '==', 1, '... F has a height of 1'); cmp_ok($G->getHeight(), '==', 2, '... G has a height of 2'); cmp_ok($H->getHeight(), '==', 1, '... H has a height of 1'); ok($D->removeChild($C), '... removed C subtree from D tree'); # | # cmp_ok($D->getHeight(), '==', 1, '... D has a height of 1'); # and the removed tree is ok cmp_ok($C->getHeight(), '==', 2, '... C has a height of 2'); cmp_ok($B->getHeight(), '==', 1, '... B has a height of 1'); } Tree-Simple-1.29/xt/0000755000175000017500000000000012712222050012375 5ustar ronronTree-Simple-1.29/xt/author/0000755000175000017500000000000012712222050013677 5ustar ronronTree-Simple-1.29/xt/author/pod_coverage.t0000644000175000017500000000037012220721733016527 0ustar ronron#!/usr/bin/perl use strict; use warnings; use Test::More; eval "use Test::Pod::Coverage 1.04"; plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; all_pod_coverage_ok({ also_private => [ qr/removeChildAt/ ] }); Tree-Simple-1.29/xt/author/changes.t0000644000175000017500000000027112626152606015511 0ustar ronron#!/usr/bin/perl use 5.006; use strict; use warnings; use Test::More; eval 'use Test::CPAN::Changes'; plan skip_all => 'Test::CPAN::Changes required for this test' if $@; changes_ok();Tree-Simple-1.29/xt/author/pod.t0000644000175000017500000000025712220721733014660 0ustar ronron#!/usr/bin/perl use strict; use warnings; use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); Tree-Simple-1.29/Changes0000644000175000017500000002406412712221770013253 0ustar ronronRevision history for Perl extension Tree::Simple. 1.29 2016-05-04T08;15:00 - Correct physical address of Free Software Foundation in LICENSE file. See RT#114149. Thanx to Petr Pisar. 1.28 2016-04-27T17:35:00 - No code changes. - Adopt workflow techniques suggested by Kent Fredric. This means a cleaner workdir and a much more reliable dist. The latter now has auto-generated MANIFEST and META.* files. 1.27 2016-04-25T09:26:00 - No code changes. - Fix my licence (sic) mess so all references are to Perl. This involves edits to Makefile.PL and LICENSE. See RT#113949. Thanx Kent Fredric. - Fix Makefile.PL so modules only used for testing are in TEST_REQUIRES and not PREREQ_PM. See RT#113948. Thanx Kent Fredric. - Fix README so it more-or-less conforms to the Perl Foundation's guidelines at http://www.perlfoundation.org/cpan_licensing_guidelines. 1.26 2015-11-28T09:30:00 - No code changes. - Accept patches from Manwar via github. See https://github.com/stevan/tree-simple/pull/10. - I (Ron) followed github's advice on handling merge conflicts from the command line, but could not see the patches after the merge. - So, create github repo https://github.com/ronsavage/Tree-Simple. - Remove Build.PL. - Reformat dates in this file. - Oops. Can't get Test::Stream to work in 10_Tree_Simple_test.t. Logged issue, but it's probably a problem with the way I tried to use Test::Stream. Revert to Test::More. - Add xt/author/changes.t to MANIFEST. 1.25 2014-01-13T08:51:00 - Fix logic in sub DESTROY for when children are/are not present. Reported by astortz. See https://github.com/stevan/tree-simple/issues/8. 1.24 2014-09-06T09:27:00 - Abandon Test::Version and hence delete t/version.t. Putting version.t in xt/author/ is not a solution, because Test::Version has problems with Test::EOL and Test::Builder. Thanx to Kent Fredric for the github issue which started me investigating this issue. 1.23 2013-11-09T10:43:00 - No code changes. - Accept spelling corrections from the Debian Perl Group, with thanx. See RT#90171. Note: The change to lib/Tree/Simple/Visitor.pm had already been made. - Add t/version.t, which uses Test::Version, to cross-check version #s. 1.22 2013-09-30T08:35:00 - Metadata fixes in Build.PL and correct bugtracker queue in Makefile.PL. Thanx to dsteinbrunner (via github). 1.21 2013-09-26T13:08:00 - Fix syntax error in Makefile.PL. 1.20 2013-09-26T11:16:00 - Merge source from https://github.com/stevan/tree-simple. - Close github issues. - Add bugtracker and license to Build.PL and Makefile.PL. 1.19 2013-09-23T08:26:00 - Maintenance now by Ron Savage. - Rectify datestamp format in this file. - Add Changelog.ini. - Make Simple.pm and Visitor.pm have the same version #. - Reformat Build.PL and Makefile.PL. - Move t/pod* into xt/author/. - Minor doc patches. - Add t/17_Tree_Simple_width_test.t. This code was attached to RT#40407, to demonstrate a bug in keeping a running total of the width (leaf count) of a tree during node additions to leaves. Thanx to David Cryer for the test code and patch. - Add t/21_Tree_Simple_Visitor_test.t. This code was attached to RT#30032, to demonstrate a bug in including the root in a traversal after calling $visitor -> includeTruck(1). - RT#30032: Adopt patch from Moses Amaro. With thanx. - RT#38607: Reject. Suppressing deep recursion warnings should not normally be done. Sub-class! - RT#40407: Adopt patch from David Cryer. With thanx. - RT#84797: Reject. Changing the return value of setUID could break any amount of code. 1.18 2007-11-11T12:00:00 - fixing version string to not choke on 5.10 (RT #29746). 1.17 2006-10-23T12:00:00 - Make loading of Scalar::Util::weaken, completely optional - Added a $post_func optional arg to &traverse. Thanks to Mark Lawrence for the patch, docs and tests :). 1.16 2006-02-06T12:00:00 - Converted to use Module::Build (Rob Kinyon) - Refactored &addChild and &addChildren to be implemented in terms of &insertChild and &insertChildren (Rob Kinyon) - Other misc. refactorings (Rob Kinyon) - Updated Scalar::Util version dependency (Stevan Little) - Updated copyrights for the new year (Stevan Little) 1.15 2005-05-26T12:00:00 - Added optional use of weakened parent references and improved the old circular reference DESTROY model to make more sense. See the documentation for more info. - Fixed bug in the fixDepth() function. 1.14 2004-11-18T12:00:00 - Now using Scalar::Util::blessed() instead of the convoluted UNIVERSAL::isa() stuff. - Added Scalar::Util as a dependency. 1.13 2004-11-15T12:00:00 - Added width functionality (with getWidth). Thanks to Mark Thomas for his insight/suggestions. - Added tests for this. - Added documentation for this. - Improved the height functionality, thanks again to Mark Thomas for his insight/suggestions. - Deprecated the 'height' method in favor of the more consistent 'getHeight' method. - Added tests for this. - Added documentation for this. - Added some info in the docs to explain the depth value for ROOT trees. - Cleaned up and improved the following test files: 11_Tree_Simple_fixDepth_test.t 13_Tree_Simple_clone_test.t 1.12 2004-10-07T12:00:00 - Fixed the clone method, it was not correctly cloning parental relationships. - Added tests and docs for this. - Improved clone and cloneShallow with the addition of the _cloneNode utility function, we now deep clone the nodes. - Added test and docs for this. 1.11 2004-10-04T12:00:00 - Some documentation changes, no code changes. 1.10 2004-08-31T12:00:00 - Streamlined the DESTROY method to avoid method calls as this can sometimes cause issues during global destruction with subclasses. 1.09 2004-08-31T12:00:00 - Fixed DESTROY to avoid memory leaks (RT-BUG: #7512). - Added documentation to explain when to call the DESTROY method to properly clean up any circular references. - Added test (14_Tree_Simple_leak_test.t) to verify this fix. Needs Test::Memory::Cycle to run. 1.08 2004-08-25T12:00:00 - Added the 'height' and 'size' methods. - Added tests for these. - Added documentation for these. 1.07 2004-07-28T12:00:00 - Added the getUID and setUID methods to Tree::Simple. Thanks to Brett Nuske for that suggestion. - Added documentation for these methods. - Added tests for those methods. - Added t/pod.t and t/pod_coverage.t to the test suite. 1.06 2004-07-06T12:00:00 - Changed what the Tree::Simple accept method accepts. - Added tests for this. - Completely Revised the Tree::Simple::Visitor object so that it is a better base class. This coincides with the release of the Tree::Simple::VisitorFactory collection of Visitor objects. - Added tests for this. 1.05 2004-06-06T12:00:00 - Fixed some vagueness in the documentation as well as made sure that the ROOT constant could be given as a the $parent argument. 1.04 2004-05-18T12:00:00 - The second argument to the Tree::Simple constructor was a parent, and that argument was not getting properly type checked before attempting to call 'addChild' on it. Now it is properly type checked and will throw an exception if it is not correct. 1.03 2004-05-09T12:00:00 - I have added a new method 'getIndex', which will fetch the index of the current tree within it's parent's child list. I have also added documentation and tests for this. 1.02 2004-05-02T12:00:00 - I thought about the API change, and I decided that the new method (removeChildAt($index) ) did not make sense. It made more sense for removeChild to accept both $child and an $index, and do the right thing based upon which one was given. This of course is how it works anyway since I maintained backwards compatibility. But take note, removeChildAt($index) will not be supported. The method is still there, but it will very soon go away. I think this is a cleaner way to do this in the end. 1.01 2004-04-28T12:00:00 - Made API change: - removeChild($index) is now removeChildAt($index) and removeChild($child) has replaced it. See the documentation for more info. - Backwards compatibility maintained under change. - New tests written to test the new code and to test the backwards compatibility. - Test suite is not at 99% coverage (with 415 tests). - Moved object initialization code from Tree::Simple::Visitor::new to Tree::Simple::Visitor::_init. This keeps in line with the Tree::Simple code and the seperation of object creation and initialization. 1.00 2004-04-05T12:00:00 - I dont know why, but I was wary of calling this 1.0 but that is really what it is. I think too many module avoid that number, but I am not gonna do that. So here goes, its 1.0 baby!! - Note: Being new to this versioning thing, I was actually going for a "minor" version thing with the jump from 0.3 to 0.14. I realized that was not only dumb, but incorrect. But in realizing this, I decided this is really 1.0 code anyway and took the plunge. 0.15 2004-04-05T12:00:00 - Made a few adjustments: - Changed to UNIVERSAL::isa($object, "Class") so as to avoid warnings if non-object refs are passed. - Added more tests to the Tree::Simple::Visitor object. - Added more tests to check for non-object-refs passed where they shouldn't be. 0.14 2004-04-04T12:00:00 - I feel this module is ready for serious use. I have been using it in production environments for almost 2 years now, and I have recently beefed up the test suite as well. It now has 371 tests with approx. 95% code coverage. I feel the code is solid as is the API (although some people dont like my Java-esque naming style, but hey whatta ya do). Most of this release is just tweaking and fine tuning of code, and updating of the documentation. 0.03 2004-04-01T12:00:00 - Like an idiot I forgot to change the version number from version 0.01 to 0.02 and because of CPAN's security-type restriction about uploading files with a duplicate name I have to up the version number. 0.02 2004-04-01T12:00:00 - First revision: - Fixed a few bugs. - Improved error messages. - Added tests: - Test for exceptions. - Checked test coverage with Devel::Cover. 0.01 2004-03-11T10:46:33 - Original version; created by h2xs 1.22 with options -X -n Tree::Simple. Tree-Simple-1.29/META.yml0000644000175000017500000000150312712222050013212 0ustar ronron--- abstract: 'A simple tree object' author: - 'Stevan Little ' build_requires: ExtUtils::MakeMaker: '0' Test::Exception: '0.15' Test::More: '1.001014' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.14, CPAN::Meta::Converter version 2.150005' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Tree-Simple no_index: directory: - t - inc requires: Scalar::Util: '1.18' constant: '0' strict: '0' warnings: '0' resources: bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Tree-Simple license: http://dev.perl.org/licenses/ repository: https://github.com/ronsavage/Tree-Simple.git version: '1.29' x_serialization_backend: 'CPAN::Meta::YAML version 0.012' Tree-Simple-1.29/MANIFEST0000644000175000017500000000130512712222050013072 0ustar ronronChangelog.ini Changes lib/Tree/Simple.pm lib/Tree/Simple/Visitor.pm LICENSE Makefile.PL MANIFEST This list of files MANIFEST.SKIP README t/10_Tree_Simple_test.t t/11_Tree_Simple_fixDepth_test.t t/12_Tree_Simple_exceptions_test.t t/13_Tree_Simple_clone_test.t t/14_Tree_Simple_leak_test.t t/14a_Tree_Simple_weak_refs_test.t t/15_Tree_Simple_height_test.t t/16_Tree_Simple_width_test.t t/17_Tree_Simple_width_test.t t/20_Tree_Simple_Visitor_test.t t/21_Tree_Simple_Visitor_test.t xt/author/changes.t xt/author/pod.t xt/author/pod_coverage.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Tree-Simple-1.29/LICENSE0000644000175000017500000004740712712215101012762 0ustar ronronTerms of Perl itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" ---------------------------------------------------------------------------- The General Public License (GPL) Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS ---------------------------------------------------------------------------- The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End