Tree-Simple-1.23000755001750001750 012237536005 12347 5ustar00ronron000000000000Tree-Simple-1.23/Changelog.ini000444001750001750 2160312237536005 15116 0ustar00ronron000000000000[Module] Name=Tree::Simple Changelog.Creator=Module::Metadata::Changes V 2.05 Changelog.Parser=Config::IniFiles V 2.78 [V 1.23] Date=2013-11-09T10:43: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= < 11_Tree_Simple_fixDepth_test.t > 13_Tree_Simple_clone_test.t EOT [V 1.12] Date=2004-10-07T12:00: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. 1.18 Sun Nov 11 12:00:00 2007 - fixing version string to not choke on 5.10 (RT #29746) 1.17 Mon Oct 23 12:00:00 2006 - 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 Mon Feb 6 12:00:00 2006 - 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 Thu May 26 12:00:00 2005 - added optional use of weakened parent references and improved the old circular reference DESTROY model to make more sense. See the documantation for more info. - fixed bug in the fixDepth() function 1.14 Thu Nov 18 12:00:00 2004 - now using Scalar::Util::blessed() instead of the convoluted UNIVERSAL::isa() stuff. - added Scalar::Util as a dependency 1.13 Mon Nov 15 12:00:00 2004 - 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 Thu Oct 7 12:00:00 2004 - 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 Mon Oct 4 12:00:00 2004 - some documentation changes, no code changes 1.10 Tue Aug 31 12:00:00 2004 - streamlined the DESTROY method to avoid method calls as this can sometimes cause issues during global destruction with subclasses. 1.09 Tue Aug 31 12:00:00 2004 - 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 Wed Aug 25 12:00:00 2004 - added the 'height' and 'size' methods - added tests for these - added documentation for these 1.07 Wed Jul 28 12:00:00 2004 - 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 Mon Jul 6 12:00:00 2004 - 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 Sun Jun 6 12:00:00 2004 - 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 Tue May 18 12:00:00 2004 - 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 Sun May 9 12:00:00 2004 - 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 Sun May 2 12:00:00 2004 - 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 Wed Apr 28 12:00:00 2004 - 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 Mon Apr 5 12:00:00 2004 - I dont know why, but I was wary of calling this 1.0 but that is really what it is. I think too many modules 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 Mon Apr 5 12:00:00 2004 - 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 shouldnt be. 0.14 Sun Apr 4 12:00:00 2004 - 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 Thu Apr 1 12:00:00 2004 - 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 Thu Apr 1 12:00:00 2004 - first revision: - fixed a few bugs - improved error messages - added tests: - test for exceptions - checked test coverage with Devel::Cover 0.01 Thu Mar 11 10:46:33 2004 - original version; created by h2xs 1.22 with options -X -n Tree::Simple Tree-Simple-1.23/Makefile.PL000444001750001750 207612237536005 14463 0ustar00ronron000000000000use 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 MANIFEST 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, 'Test::Exception' => '0.15', 'Test::More' => '0.47', 'Test::Version' => 1.002003, 'warnings' => 0, }, VERSION_FROM => 'lib/Tree/Simple.pm', ); if ( ($ExtUtils::MakeMaker::VERSION =~ /^\d\.\d\d$/) && ($ExtUtils::MakeMaker::VERSION > 6.30) ) { $params{LICENSE} = 'artistic_2'; } if ($ExtUtils::MakeMaker::VERSION ge '6.46') { $params{META_MERGE} = { resources => { bugtracker => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Tree-Simple', license => 'http://www.perlfoundation.org/artistic_license_2_0', }, }; } WriteMakefile(%params); Tree-Simple-1.23/README000444001750001750 111612237536005 13363 0ustar00ronron000000000000Tree/Simple version 1.18 ======================== See the module documentation for more information. INSTALLATION To install this module type the following: perl Makefile.PL make make test make install DEPENDENCIES This module requires no other modules and libraries outside of the core for normal usage. However it uses Test::Exception in the test suite. COPYRIGHT AND LICENCE Copyright (C) 2004-2006 Infinity Interactive, Inc. http://www.iinteractive.com This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Tree-Simple-1.23/META.yml000444001750001750 153712237536005 13763 0ustar00ronron000000000000--- abstract: 'A simple tree object' author: - 'Stevan Little ' build_requires: Test::Exception: 0.15 Test::More: 0.47 Test::Version: 1.002003 configure_requires: Module::Build: 0.4 dynamic_config: 1 generated_by: 'Module::Build version 0.4005, CPAN::Meta::Converter version 2.131560' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Tree-Simple provides: Tree::Simple: file: lib/Tree/Simple.pm version: 1.23 Tree::Simple::Visitor: file: lib/Tree/Simple/Visitor.pm version: 1.23 requires: Scalar::Util: 1.18 constant: 0 strict: 0 warnings: 0 resources: bugtracker: https://github.com/stevan/tree-simple/issues license: https://www.gnu.org/licenses/license-list.html#PerlLicense repository: https://github.com/stevan/tree-simple version: 1.23 Tree-Simple-1.23/MANIFEST000444001750001750 100612237536005 13632 0ustar00ronron000000000000Build.PL Changelog.ini Changes lib/Tree/Simple.pm lib/Tree/Simple/Visitor.pm Makefile.PL MANIFEST META.json META.yml 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 t/version.t xt/author/pod.t xt/author/pod_coverage.t Tree-Simple-1.23/Build.PL000444001750001750 144612237536005 14005 0ustar00ronron000000000000use 5.006; use strict; use warnings; use Module::Build; Module::Build -> new ( dist_abstract => 'A simple tree object', dist_author => 'Stevan Little ', license => 'perl', module_name => 'Tree::Simple', build_requires => { 'Test::Exception' => '0.15', 'Test::More' => '0.47', 'Test::Version' => 1.002003, }, configure_requires => { 'Module::Build' => 0.40, }, requires => { 'constant' => 0, 'Scalar::Util' => '1.18', 'strict' => 0, 'warnings' => 0, }, meta_merge => { resources => { repository => 'https://github.com/stevan/tree-simple', bugtracker => 'https://github.com/stevan/tree-simple/issues', license => 'https://www.gnu.org/licenses/license-list.html#PerlLicense', }, }, ) -> create_build_script; Tree-Simple-1.23/META.json000444001750001750 273012237536005 14127 0ustar00ronron000000000000{ "abstract" : "A simple tree object", "author" : [ "Stevan Little " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4005, CPAN::Meta::Converter version 2.131560", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Tree-Simple", "prereqs" : { "build" : { "requires" : { "Test::Exception" : "0.15", "Test::More" : "0.47", "Test::Version" : "1.002003" } }, "configure" : { "requires" : { "Module::Build" : "0.4" } }, "runtime" : { "requires" : { "Scalar::Util" : "1.18", "constant" : "0", "strict" : "0", "warnings" : "0" } } }, "provides" : { "Tree::Simple" : { "file" : "lib/Tree/Simple.pm", "version" : "1.23" }, "Tree::Simple::Visitor" : { "file" : "lib/Tree/Simple/Visitor.pm", "version" : "1.23" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/stevan/tree-simple/issues" }, "license" : [ "https://www.gnu.org/licenses/license-list.html#PerlLicense" ], "repository" : { "url" : "https://github.com/stevan/tree-simple" } }, "version" : "1.23" } Tree-Simple-1.23/xt000755001750001750 012237536005 13002 5ustar00ronron000000000000Tree-Simple-1.23/xt/author000755001750001750 012237536005 14304 5ustar00ronron000000000000Tree-Simple-1.23/xt/author/pod_coverage.t000444001750001750 37012237536005 17243 0ustar00ronron000000000000#!/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.23/xt/author/pod.t000444001750001750 25712237536005 15374 0ustar00ronron000000000000#!/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.23/t000755001750001750 012237536005 12612 5ustar00ronron000000000000Tree-Simple-1.23/t/11_Tree_Simple_fixDepth_test.t000444001750001750 1152312237536005 20561 0ustar00ronron000000000000#!/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.23/t/20_Tree_Simple_Visitor_test.t000444001750001750 1530212237536005 20444 0ustar00ronron000000000000#!/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.23/t/21_Tree_Simple_Visitor_test.t000444001750001750 150512237536005 20425 0ustar00ronron000000000000#!/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.23/t/14a_Tree_Simple_weak_refs_test.t000444001750001750 1100412237536005 21112 0ustar00ronron000000000000#!/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.23/t/12_Tree_Simple_exceptions_test.t000444001750001750 2672212237536005 21177 0ustar00ronron000000000000#!/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.23/t/17_Tree_Simple_width_test.t000444001750001750 107612237536005 20115 0ustar00ronron000000000000#!/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.23/t/15_Tree_Simple_height_test.t000444001750001750 1351712237536005 20267 0ustar00ronron000000000000#!/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.23/t/16_Tree_Simple_width_test.t000444001750001750 1510612237536005 20133 0ustar00ronron000000000000#!/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.23/t/13_Tree_Simple_clone_test.t000444001750001750 1353712237536005 20117 0ustar00ronron000000000000#!/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.23/t/10_Tree_Simple_test.t000444001750001750 7730112237536005 16733 0ustar00ronron000000000000#!/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.23/t/version.t000444001750001750 26512237536005 14604 0ustar00ronron000000000000use strict; use warnings; use Test::More; use Test::Version 'version_all_ok', {is_strict => 1}; # ------------------------------------------------ version_all_ok; done_testing; Tree-Simple-1.23/t/14_Tree_Simple_leak_test.t000444001750001750 1267712237536005 17740 0ustar00ronron000000000000#!/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 => 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.23/lib000755001750001750 012237536005 13115 5ustar00ronron000000000000Tree-Simple-1.23/lib/Tree000755001750001750 012237536005 14014 5ustar00ronron000000000000Tree-Simple-1.23/lib/Tree/Simple.pm000444001750001750 13006212237536005 16002 0ustar00ronron000000000000package Tree::Simple; use strict; use warnings; our $VERSION = '1.23'; 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 unless (!$self->{_children} && scalar(@{$self->{_children}}) == 0) { 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); # explicity add a child to it $tree->addChild(Tree::Simple->new("1")); # specify the parent when creating # an instance and it adds the child implicity 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 don't 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 parent's children. 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 object's hex address is provided for you, so use of this method is entirely optional. It is the responsibility of the user to ensure the value's 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 it's 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 it's 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's type 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 from it's 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 it's 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 object's node field. =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 invocant's parent. =item B Returns a number representing the invocant's depth within the hierarchy of B objects. B A C tree has the depth of -1. This be because Tree::Simple assumes that a tree's root 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 invocant's parent, 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 parent's child 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's "parent" field is 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 child's children 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's 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 your tree's 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 invocant's sub-trees correcting the depth as it goes. =item B Tree::Simple will manage your tree's 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 it's ancestors. =item B Tree::Simple will manage your tree's 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 it's ancestors. =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's primary responsibility is 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 it's children to detach from it, however, if a child is destroyed it will not be detached from it's 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 perl's 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 this module's 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 - A set of classes for viewing Tree::Simple hierarchies in various output formats. =item L - A set of several useful Visitor objects for Tree::Simple objects. =item L - If you are looking for a binary tree, this you might want to 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. However, B does not come with any automated tests. It's I file simply checks the module loads and nothing else. 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 doesn't 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 can't 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.23/lib/Tree/Simple000755001750001750 012237536005 15245 5ustar00ronron000000000000Tree-Simple-1.23/lib/Tree/Simple/Visitor.pm000444001750001750 2301712237536005 17422 0ustar00ronron000000000000package Tree::Simple::Visitor; use strict; use warnings; our $VERSION = '1.23'; 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 don't 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 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