Tree-MultiNode-1.0.14/0000755000000000000000000000000014002477620013072 5ustar rootrootTree-MultiNode-1.0.14/Makefile.PL0000644000000000000000000000167114002477617015057 0ustar rootrootuse strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Tree::MultiNode', AUTHOR => 'Kyle R. Burton ', VERSION_FROM => 'lib/Tree/MultiNode.pm', ABSTRACT_FROM => 'lib/Tree/MultiNode.pm', PL_FILES => {}, ($ExtUtils::MakeMaker::VERSION >= 6.3002 ? ('LICENSE' => 'perl', ) : ()), PREREQ_PM => { 'Test::More' => 0, # For testing }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Tree-MultiNode-*' }, META_MERGE => { build_requires => { 'Test::More' => 0, # For testing }, resources => { license => 'http://dev.perl.org/licenses/', bugtracker => 'https://github.com/toddr/Tree-MultiNode/issues', repository => 'https://github.com/toddr/Tree-MultiNode', }, }, ); Tree-MultiNode-1.0.14/README0000644000000000000000000000177514002477617013772 0ustar rootrootName DLSI Description Info --------------- ---- --------------------------------- -------- Tree::MultiNode adpO Multi node unordered tree objects KRBURTON This is an implementation of a multi node tree. The uniqueness of keys is not enforced, nor is there enforcement of ordering of nodes. Tree::MultiNode was created to aid in modeling heriarchical relationships, like the relationships inherent in the records from a RDBMS. Where multi-to-multi relationships could produce multiple child nodes with the same types or basic attributes. Unique key enforcement would be inappropriate in these cases (at least for me). Copyright 1997-2002 Kyle R. Burton. All rights reserved. mortis@voicenet.com http://www.voicenet.com/~mortis This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the terms of the Perl Artistic License (see http://www.perl.com/perl/misc/Artistic.html) Tree-MultiNode-1.0.14/t/0000755000000000000000000000000014002477617013343 5ustar rootrootTree-MultiNode-1.0.14/t/01-multinode.t0000644000000000000000000000530414002477617015750 0ustar rootroot#!perl -T use Test::More tests => 71; use Tree::MultiNode; my $tree = Tree::MultiNode->new; my $handle = Tree::MultiNode::Handle->new($tree); isa_ok($tree, 'Tree::MultiNode'); isa_ok($handle, 'Tree::MultiNode::Handle'); $handle->add_child("a", 1); $handle->add_child("b", 1); $handle->add_child("c", 1); $handle->remove_child(1); my %pairs = $handle->kv_pairs(); pass("**** [$0] Pairs: " . join(', ',%pairs)); ok(!defined $pairs{'b'}, "pair b not defined"); ok( defined $pairs{'a'}, "pair a defined"); ok( defined $pairs{'c'}, "pair c defined"); pass("**** testing traverse..."); pass("**** ....t digit formatting..."); $tree = new Tree::MultiNode(); $handle = new Tree::MultiNode::Handle($tree); isa_ok($tree, 'Tree::MultiNode'); isa_ok($handle, 'Tree::MultiNode::Handle'); is($handle->set_key('1'), 1, 'set_key'); is($handle->set_value('foo'), 'foo', 'set_value'); is($handle->add_child('1:1','bar'), undef, ' add_child("1:1", "bar")'); is($handle->down(0), 1, ' down(0)');; is($handle->add_child('1:1:1','baz'), undef, ' add_child("1:1:1", "baz")'); is($handle->add_child('1:1:2','boz'), undef, ' add_child("1:1:1", "boz")'); is($handle->up(), 1, ' up'); is($handle->add_child('1:2','qux'), undef, ' add_child("1:2", "qux")'); is($handle->down(1), 1, ' down(1)'); is($handle->add_child('1:2:1','qaz'), undef, ' add_child("1:2:1","qaz")'); is($handle->add_child('1:2:2','qoz'), undef, ' add_child("1:2:2","qoz")'); is($handle->top(), 1, "move to top of tree"); my $count = 0; $handle->traverse(sub { my $h = pop; pass(sprintf("**** %sk: %- 5s v: %s", ' ' x $handle->depth, $h->get_data)); $count++; isa_ok($h, 'Tree::MultiNode::Handle'); is($_[0], 'arg1', "Traverse argument 1 received"); is($_[1], 'arg2', "Traverse argument 2 received"); is($_[2], 'arg3', "Traverse argument 3 received"); }, 'arg1', 'arg2', 'arg3' ); pass("**** Testing select..."); is($handle->top(), 1, "move to top of tree"); pass("**** Children: " . join(', ',$handle->child_keys())); is($handle->select('1:2'), 1, "Select 1:2") or die("Error, select() failed"); is($handle->down(), 1, "down()"); is($handle->get_value, 'qux', "select(1:2) positioned on the correct child"); is($count, 7, "Traversed 7 nodes"); pass("**** test storing 'zero' as a child key"); is($handle->add_child('zero','fuzz'), undef, 'add_child("zero", "fuzz")'); is($handle->last, 2, 'last() -- TODO: Why is this a 2 return?'); is($handle->down, 1, "down()"); is($handle->get_value, 'fuzz', "down sent us to key with value fuzz"); is($handle->set_key(0), 0, "set_key(0)"); is($handle->get_key, 0, "0 Stores as a key"); #done_testing(); Tree-MultiNode-1.0.14/t/00-load.t0000644000000000000000000000023614002477617014665 0ustar rootroot#!perl -T use Test::More tests => 1; BEGIN { use_ok( 'Tree::MultiNode' ); } diag( "Testing Tree::MultiNode $Tree::MultiNode::VERSION, Perl $], $^X" ); Tree-MultiNode-1.0.14/xt/0000755000000000000000000000000014002477617013533 5ustar rootrootTree-MultiNode-1.0.14/xt/99-pod.t0000644000000000000000000000035014002477617014737 0ustar rootroot#!perl -T use strict; use warnings; use Test::More; # Ensure a recent version of Test::Pod my $min_tp = 1.22; eval "use Test::Pod $min_tp"; plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; all_pod_files_ok(); Tree-MultiNode-1.0.14/xt/98-pod-coverage.t0000644000000000000000000000104714002477617016533 0ustar rootrootuse strict; use warnings; use Test::More; # Ensure a recent version of Test::Pod::Coverage my $min_tpc = 1.08; eval "use Test::Pod::Coverage $min_tpc"; plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@; # Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, # but older versions don't recognize some common documentation styles my $min_pc = 0.18; eval "use Pod::Coverage $min_pc"; plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@; all_pod_coverage_ok(); Tree-MultiNode-1.0.14/INSTALL0000644000000000000000000000207214002477617014132 0ustar rootrootTree::MultiNode Installation Instructions To install this module, just do: perl Build.PL ./Build ./Build test ./Build install (this step may need to be done as the superuser) Or, if you're on a platform (like DOS or Windows) that doesn't require the "./" notation, you can do this: perl Build.PL Build Build test Build install The important thing is that the "Build" script gets executed and that you pass it the "test", "install", etc. arguments. If you really want to, you can use a more traditional Makefile.PL: perl Makefile.PL make test make install (this step may need to be done as the superuser) Substitute "nmake" or "gmake" for "make" if you use some other make-alike on your platform - 'perl -V:make' can tell you what you should use. I recommend using the Build.PL option. If you use the Makefile.PL option, you'll actually be using the Build.PL option under the surface anyway, with a pass-through Makefile. There's heaps more information in the README and in the documentation of the various packages in this distribution. -ToddTree-MultiNode-1.0.14/MANIFEST0000644000000000000000000000045014002477620014222 0ustar rootrootChanges INSTALL lib/Tree/MultiNode.pm Makefile.PL MANIFEST README t/00-load.t t/01-multinode.t xt/98-pod-coverage.t xt/99-pod.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Tree-MultiNode-1.0.14/Changes0000644000000000000000000001152714002477617014401 0ustar rootrootRevision history for Perl extension Tree::MultiNode. 1.0.14 Fri Jan 22 2020 - Switch to github CI - Switch to github issue tracker. RT going away. - Now using Makefile.PL - perltidy 1.0.13 Fri Feb 19 2010 11:00:00 CST 2010 - Pause hung uploading 1.0.12 grr... 1.0.12 Fri Feb 19 2010 09:00:00 CST 2010 - Tweak to new documentation for CPAN 1.0.11 Fri Feb 19 2010 01:00:00 CST 2010 - Convert module to standart treee layout. - Convert to Test::More suite with additional tests - Generat META.yml file from new Build.PL data - RT #5107 - Documentation patch for Tree-MultiNode-1.0.10 - RT #1743 - Documentation fix for traverse example to be consistent with code - RT #5435 - New add_child_node sub to merge trees - TODO: Need proper pod documentation for new sub. - TODO: Need tests for the new feature. 1.0.10 Tue May 27 14:06:33 EDT 2003 KRB: Markus Maier found a bug in the tree's destructor that happens when a reference to a handle outlives the tree object. $self->{'top'} is then undefined and _clearrefs should not be called (a second time). KRB: fixed documentaiton bug (set_key/set_value), added use strict and warnings to the example in the POD. 1.0.9 Tue Oct 8 20:38:52 EDT 2002 KRB: Gregg Casillo sent in a fix that now allows keys to store the numeric value 0. KRB: fixed reported bug with traverse not passing the new handle. 1.0.8 Wed May 8 10:06:22 EDT 2002 KRB: Papp Zoltan pointed out a bug in Tree::MultiNode::Node's _clearrefs() where an array ref was not being dereferenced correctly. The fix has been applied. 1.0.7 Tue Nov 13 09:00:49 EST 2001 KRB: "Tunkelo Heikki (extern)" subumitted a patch that fixed the select() method. 1.0.6 Wed Dec 13 11:43:11 EST 2000 KRB: traverse was created because of comments from Sverrir Jonsson 1.0.5 Wed Dec 13 11:32:57 EST 2000 KRB: updated traverse so you can pass additional constant arguments to the sub ref. 1.0.4 Wed Dec 13 11:03:17 EST 2000 KRB: added Tree::MultiNode::Handle::traverse as a method that takes a sub ref and invokes the subref for each node in the tree. 1.0.3 Thu Sep 7 11:57:14 EDT 2000 KRB: added Tree::MultiNode::DESTROY, and Tree::MultiNode::Node::_clearrefs so the refcounts of the nodes, as well as the data will go to zero. Eric Joanis pointed out this bug, and sent me an example. The chagnes are based largely on his work, with minor modifications. 1.0.1 Tue Nov 23 11:05:42 EST 1999 KRB: added child_keys to the handle object to return the child keys from the current node. 1.0.1 Fri Jun 4 08:56:26 EDT 1999 KRB: fixed print message in get_child_value() -- it should only print when $debug is defined...the bug was reported by Kohei Ohta 1.0.0 Mon May 17 11:25:51 EDT 1999 DXP: Applied patch from Daniel X. Pape dpape@canis.uiuc.edu, which included: - Node, and Handle objects: moved tree() member function from Node object to Handle object - Handle object: added functionality, and member function for depth tracking as the Handle object is navigated through the tree. - Documentation for the new code. KRB: Added Handle::kv_pairs(), and Handle::remove_child(). KRB: Made minor changes to the debug statements so they print the package name as well as the member function name - just to make it easier to see these messages when used in conjunction with other objects/packages/debugging code. KRB: Minor changes to the new() member functions, so the objects can be constructed in a larger variety of ways. KRB: It seemed stable enough, and failry feature complete, and there didn't seem like there were any more compelling reasons not to, so I updated the version number to 1.0.0 so it looks stable. KRB: All previous changes made by KRB... 0.9.4 Wed Apr 14 12:35:01 EDT 1999 Fixed the issue with make test, and re-released it as 0.9.4 - make test wasn't outputting the standard test output ("ok x"). This was sparked by the CPAN testers group. Thanks. 0.9.3 Wed Nov 4 16:17:49 EST 1998 Again, some minor bug fixes. 0.9.2 Wed Nov 4 16:17:49 EST 1998 Some minor debugging, and added some (hopefuly useful) member functions. 0.9.1 Wed Oct 28 09:39:17 EST 1998 First release to CPAN -- 0.9.1 0.9.1 Wed Oct 28 09:39:17 EST 1998 Made namespace change as suggested by Andreas J. Koenig, and created _alot_ more documentation. 0.9.0 Tue Oct 27 10:34:49 EST 1998 Created Initial Version (multi_tree.pm) Tree-MultiNode-1.0.14/lib/0000755000000000000000000000000014002477617013646 5ustar rootrootTree-MultiNode-1.0.14/lib/Tree/0000755000000000000000000000000014002477617014545 5ustar rootrootTree-MultiNode-1.0.14/lib/Tree/MultiNode.pm0000644000000000000000000010014414002477617017003 0ustar rootroot =head1 NAME Tree::MultiNode -- a multi-node tree object. Most useful for modeling hierarchical data structures. =head1 SYNOPSIS use Tree::MultiNode; use strict; use warnings; my $tree = new Tree::MultiNode; my $handle = new Tree::MultiNode::Handle($tree); $handle->set_key("top"); $handle->set_value("level"); $handle->add_child("child","1"); $handle->add_child("child","2"); $handle->first(); $handle->down(); $handle->add_child("grandchild","1-1"); $handle->up(); $handle->last(); $handle->down(); $handle->add_child("grandchild","2-1"); $handle->up(); $handle->top(); &dump_tree($handle); my $depth = 0; sub dump_tree { ++$depth; my $handle = shift; my $lead = ' ' x ($depth*2); my($key,$val); ($key,$val) = $handle->get_data(); print $lead, "key: $key\n"; print $lead, "val: $val\n"; print $lead, "depth: $depth\n"; my $i; for( $i = 0; $i < scalar($handle->children); ++$i ) { $handle->down($i); &dump_tree($handle); $handle->up(); } --$depth; } =head1 DESCRIPTION Tree::MultiNode, Tree::MultiNode::Node, and MultiNode::Handle are objects modeled after C++ classes that I had written to help me model hierarchical information as data structures (such as the relationships between records in an RDBMS). The tree is basically a list of lists type data structure, where each node has a key, a value, and a list of children. The tree has no internal sorting, though all operations preserve the order of the child nodes. =head2 Creating a Tree The concept of creating a handle based on a tree lets you have multiple handles into a single tree without having to copy the tree. You have to use a handle for all operations on the tree (other than construction). When you first construct a tree, it will have a single empty node. When you construct a handle into that tree, it will set the top node in the tree as it's current node. my $tree = new Tree::MultiNode; my $handle = new Tree::MultiNode::Handle($tree); =head2 Using a Handle to Manipulate the Tree At this point, you can set the key/value in the top node, or start adding child nodes. $handle->set_key("blah"); $handle->set_value("foo"); $handle->add_child("quz","baz"); # or $handle->add_child(); add_child can take 3 parameters -- a key, a value, and a position. The key and value will set the key/value of the child on construction. If pos is passed, the new child will be inserted into the list of children. To move the handle so it points at a child (so you can start manipulating that child), there are a series of methods to call: $handle->first(); # sets the current child to the first in the list $handle->next(); # sets the next, or first if there was no next $handle->prev(); # sets the previous, or last if there was no next $handle->last(); # sets to the last child $handle->down(); # positions the handle's current node to the # current child To move back up, you can call the method up: $handle->up(); # moves to this node's parent up() will fail if the current node has no parent node. Most of the member functions return either undef to indicate failure, or some other value to indicate success. =head2 $Tree::MultiNode::debug If set to a true value, it enables debugging output in the code. This will likely be removed in future versions as the code becomes more stable. =head1 API REFERENCE =cut ################################################################################ =head2 Tree::MultiNode The tree object. =cut package Tree::MultiNode; use strict; use vars qw( $VERSION @ISA ); require 5.004; $VERSION = '1.0.14'; @ISA = (); =head2 Tree::MultiNode::new @param package name or tree object [scalar] @returns new tree object Creates a new Tree. The tree will have a single top level node when created. The first node will have no value (undef) in either it's key or it's value. my $tree = new Tree::MultiNode; =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = {}; bless $self, $class; $self->{'top'} = Tree::MultiNode::Node->new(); return $self; } # # this destructor is for clearing the circular references between # the tree, the nodes, and their children. # sub DESTROY { my $self = shift; $self->{'top'}->_clearrefs() if $self->{'top'}; } 1; ################################################################################ package Tree::MultiNode::Node; use strict; use Carp; =head2 Tree::MultiNode::Node Please note that the Node object is used internally by the MultiNode object. Though you have the ability to interact with the nodes, it is unlikely that you should need to. That being said, the interface is documented here anyway. =cut =head2 Tree::MultiNode::Node::new new($) @param package name or node object to clone [scalar] @returns new node object new($$) @param key [scalar] @param value [scalar] @returns new node object Creates a new Node. There are three behaviors for new. A constructor with no arguments creates a new, empty node. A single argument of another node object will create a clone of the node object. If two arguments are passed, the first is stored as the key, and the second is stored as the value. # clone an existing node my $node = new Tree::MultiNode::Node($oldNode); # or my $node = $oldNode->new(); # create a new node my $node = new Tree::MultiNode::Node; my $node = new Tree::MultiNode::Node("fname"); my $node = new Tree::MultiNode::Node("fname","Larry"); =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = {}; bless $self, $class; my $node = shift; if ( ref($node) eq "Tree::MultiNode::Node" ) { # become a copy of that node... $self->_clone($node); } else { my ( $key, $value ); $key = $node; $value = shift; print __PACKAGE__, "::new() key,val = $key,$value\n" if $Tree::MultiNode::debug; $self->{'children'} = []; $self->{'parent'} = undef; $self->{'key'} = $key || undef; $self->{'value'} = defined $value ? $value : undef; } return $self; } # # internal method for making the current node a clone of another # node... # sub _clone { my $self = shift; my $them = shift; $self->{'parent'} = $them->parent; $self->{'children'} = [ $them->children ]; $self->{'key'} = $them->key; $self->{'value'} = $them->value; } =head2 Tree::MultiNode::Node::key @param key [scalar] @returns the key [scalar] Used to set, or retrieve the key for a node. If a parameter is passed, it sets the key for the node. The value of the key member is always returned. print $node3->key(), "\n"; # 'fname' =cut sub key { my ( $self, $key ) = @_; if ( @_ > 1 ) { print __PACKAGE__, "::key() setting key: $key on $self\n" if $Tree::MultiNode::debug; $self->{'key'} = $key; } return $self->{'key'}; } =head2 Tree::MultiNode::Node::value @param the value to set [scalar] @returns the value [scalar] Used to set, or retrieve the value for a node. If a parameter is passed, it sets the value for the node. The value of the value member is always returned. print $node3->value(), "\n"; # 'Larry' =cut sub value { my $self = shift; my $value = shift; if ( defined $value ) { print __PACKAGE__, "::value() setting value: $value on $self\n" if $Tree::MultiNode::debug; $self->{'value'} = $value; } return $self->{'value'}; } =head2 Tree::MultiNode::Node::clear_key @returns the deleted key Clears the key member by deleting it. $node3->clear_key(); =cut sub clear_key { my $self = shift; return delete $self->{'key'}; } =head2 Tree::MultiNode::Node::clear_value @returns the deleted value Clears the value member by deleting it. $node3->clear_value(); =cut sub clear_value { my $self = shift; return delete $self->{'value'}; } =head2 Tree::MultiNode::Node::children @returns reference to children [array reference] Returns a reference to the array that contains the children of the node object. $array_ref = $node3->children(); =cut sub children { my $self = shift; return $self->{'children'}; } =head2 Tree::MultiNode::Node::child_keys Tree::MultiNode::Node::child_values Tree::MultiNode::Node::child_kv_pairs These functions return arrays consisting of the appropriate data from the child nodes. my @keys = $handle->child_keys(); my @vals = $handle->child_values(); my %kv_pairs = $handle->child_kv_pairs(); =cut sub child_keys { my $self = shift; my $children = $self->{'children'}; my @keys; my $node; foreach $node (@$children) { push @keys, $node->key(); } return @keys; } sub child_values { my $self = shift; my $children = $self->{'children'}; my @values; my $node; foreach $node (@$children) { push @values, $node->value(); } return @values; } sub child_kv_pairs { my $self = shift; my $children = $self->{'children'}; my %h; my $node; foreach $node (@$children) { $h{ $node->key() } = $node->value(); } return %h; } =head2 Tree::MultiNode::Node::child_key_positions This function returns a hash table that consists of the child keys as the hash keys, and the position in the child array as the value. This allows for a quick and dirty way of looking up the position of a given key in the child list. my %h = $node->child_key_positions(); =cut sub child_key_positions { my $self = shift; my $children = $self->{'children'}; my ( %h, $i, $node ); $i = 0; foreach $node (@$children) { $h{ $node->key() } = $i++; } return %h; } =head2 Tree::MultiNode::Node::parent Returns a reference to the parent node of the current node. $node_parent = $node3->parent(); =cut sub parent { my $self = shift; return $self->{'parent'}; } =head2 Tree::MultiNode::Node::dump Used for diagnostics, it prints out the members of the node. $node3->dump(); =cut sub dump { my $self = shift; print "[dump] key: ", $self->{'key'}, "\n"; print "[dump] val: ", $self->{'value'}, "\n"; print "[dump] parent: ", $self->{'parent'}, "\n"; print "[dump] children: ", $self->{'children'}, "\n"; } sub _clearrefs { my $self = shift; delete $self->{'parent'}; foreach my $child ( @{ $self->children() } ) { $child->_clearrefs(); } delete $self->{'children'}; } 1; ################################################################################ package Tree::MultiNode::Handle; use strict; use Carp; =head2 Tree::MultiNode::Handle Handle is used as a 'pointer' into the tree. It has a few attributes that it keeps track of. These are: 1. the top of the tree 2. the current node 3. the current child node 4. the depth of the current node The top of the tree never changes, and you can reset the handle to point back at the top of the tree by calling the top() method. The current node is where the handle is 'pointing' in the tree. The current node is changed with functions like top(), down(), and up(). The current child node is used for traversing downward into the tree. The members first(), next(), prev(), last(), and position() can be used to set the current child, and then traverse down into it. The depth of the current node is a measure of the length of the path from the top of the tree to the current node, i.e., the top of the node has a depth of 0, each of its children has a depth of 1, etc. =cut =head2 Tree::MultiNode::Handle::New Constructs a new handle. You must pass a tree object to Handle::New. my $tree = new Tree::MultiNode; my $handle = new Tree::MultiNode::Handle($tree); =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = {}; bless $self, $class; my $data = shift; print __PACKAGE__, "::new() ref($data) is: ", ref($data), "\n" if $Tree::MultiNode::debug; if ( ref($data) eq "Tree::MultiNode::Handle" ) { $self->_clone($data); } else { unless ( ref($data) eq "Tree::MultiNode" ) { confess "Error, invalid Tree::MultiNode reference: $data\n"; } $self->{'tree'} = $data; $self->{'curr_pos'} = undef; $self->{'curr_node'} = $data->{'top'}; $self->{'curr_child'} = undef; $self->{'curr_depth'} = 0; } return $self; } # # internal method for making the current handle a copy of another # handle... # sub _clone { my $self = shift; my $them = shift; print __PACKAGE__, "::_clone() cloning: $them\n" if $Tree::MultiNode::debug; print __PACKAGE__, "::_clone() depth: ", $them->{'curr_depth'}, "\n" if $Tree::MultiNode::debug; $self->{'tree'} = $them->{'tree'}; $self->{'curr_pos'} = $them->{'curr_pos'}; $self->{'curr_node'} = $them->{'curr_node'}; $self->{'curr_child'} = $them->{'curr_child'}; $self->{'curr_depth'} = $them->{'curr_depth'}; return 1; } =head2 Tree::MultiNode::Handle::tree Returns the tree that was used to construct the node. Useful if you're trying to create another node into the tree. my $handle2 = new Tree::MultiNode::Handle($handle->tree()); =cut sub tree { my $self = shift; return $self->{'tree'}; } =head2 Tree::MultiNode::Handle::get_data Retrieves both the key, and value (as an array) for the current node. my ($key,$val) = $handle->get_data(); =cut sub get_data { my $self = shift; my $node = $self->{'curr_node'}; return ( $node->key, $node->value ); } =head2 Tree::MultiNode::Handle::get_key Retrieves the key for the current node. $key = $handle->get_key(); =cut sub get_key { my $self = shift; my $node = $self->{'curr_node'}; my $key = $node->key(); print __PACKAGE__, "::get_key() getting from $node : $key\n" if $Tree::MultiNode::debug; return $key; } =head2 Tree::MultiNode::Handle::set_key Sets the key for the current node. $handle->set_key("lname"); =cut sub set_key { my $self = shift; my $key = shift; my $node = $self->{'curr_node'}; print __PACKAGE__, "::set_key() setting key \"$key\" on: $node\n" if $Tree::MultiNode::debug; return $node->key($key); } =head2 Tree::MultiNode::Handle::get_value Retrieves the value for the current node. $val = $handle->get_value(); =cut sub get_value { my $self = shift; my $node = $self->{'curr_node'}; my $value = $node->value(); print __PACKAGE__, "::get_value() getting from $node : $value\n", if $Tree::MultiNode::debug; return $value; } =head2 Tree::MultiNode::Handle::set_value Sets the value for the current node. $handle->set_value("Wall"); =cut sub set_value { my $self = shift; my $value = shift; my $node = $self->{'curr_node'}; print __PACKAGE__, "::set_value() setting value \"$value\" on: $node\n" if $Tree::MultiNode::debug; return $node->value($value); } =head2 Tree::MultiNode::Handle::get_child get_child takes an optional parameter which is the position of the child that is to be retrieved. If this position is not specified, get_child attempts to return the current child. get_child returns a Node object. my $child_node = $handle->get_child(); =cut sub get_child { my $self = shift; my $children = $self->{'curr_node'}->children; my $pos = shift || $self->{'curr_pos'}; print __PACKAGE__, "::get_child() children: $children $pos\n" if $Tree::MultiNode::debug; unless ( defined $children ) { return undef; } unless ( defined $pos && $pos <= $#{$children} ) { my $num = $#{$children}; confess "Error, $pos is an invalid position [$num] $children.\n"; } print __PACKAGE__, "::get_child() returning [$pos]: ", ${$children}[$pos], "\n" if $Tree::MultiNode::debug; return ( ${$children}[$pos] ); } =head2 Tree::MultiNode::Handle::add_child This member adds a new child node to the end of the array of children for the current node. There are three optional parameters: - a key - a value - a position If passed, the key and value will be set in the new child. If a position is passed, the new child will be inserted into the current array of children at the position specified. $handle->add_child(); # adds a blank child $handle->add_child("language","perl"); # adds a child to the end $handle->add_child("language","C++",0); # adds a child to the front =cut sub add_child { my $self = shift; my ( $key, $value, $pos ) = @_; my $children = $self->{'curr_node'}->children; print __PACKAGE__, "::add_child() children: $children\n" if $Tree::MultiNode::debug; my $curr_pos = $self->{'curr_pos'}; my $curr_node = $self->{'curr_node'}; my $child = Tree::MultiNode::Node->new( $key, $value ); $child->{'parent'} = $curr_node; print __PACKAGE__, "::add_child() adding child $child ($key,$value) ", "to: $children\n" if $Tree::MultiNode::debug; if ( defined $pos ) { print __PACKAGE__, "::add_child() adding at $pos $child\n" if $Tree::MultiNode::debug; unless ( $pos <= $#{$children} ) { my $num = $#{$children}; confess "Position $pos is invalid for child position [$num] $children.\n"; } splice( @{$children}, $pos, 1, $child, ${$children}[$pos] ); } else { print __PACKAGE__, "::add_child() adding at end $child\n" if $Tree::MultiNode::debug; push @{$children}, $child; } print __PACKAGE__, "::add_child() children:", join( ',', @{ $self->{'curr_node'}->children } ), "\n" if $Tree::MultiNode::debug; } =head2 Tree::MultiNode::Handle::add_child_node Recently added via RT # 5435 -- Currently in need of proper documentation and test patches I've patched Tree::MultiNode 1.0.10 to add a method I'm currently calling add_child_node(). It works just like add_child() except it takes either a Tree::MultiNode::Node or a Tree::MultiNode object instead. I found this extremely useful when using recursion to populate a tree. It could also be used to subsume any tree into another tree, so this touches on the topic of the other bug item here asking for methods to copy/move trees/nodes. =cut sub add_child_node { my $self = shift; my ( $child, $pos ) = @_; my $children = $self->{'curr_node'}->children; print __PACKAGE__, "::add_child_node() children: $children\n" if $Tree::MultiNode::debug; my $curr_pos = $self->{'curr_pos'}; my $curr_node = $self->{'curr_node'}; if ( ref($child) eq 'Tree::MultiNode' ) { my $top = $child->{'top'}; $child->{'top'} = undef; $child = $top; } confess "Invalid child argument.\n" if ( ref($child) ne 'Tree::MultiNode::Node' ); $child->{'parent'} = $curr_node; print __PACKAGE__, "::add_child_node() adding child $child ", "to: $children\n" if $Tree::MultiNode::debug; if ( defined $pos ) { print __PACKAGE__, "::add_child_node() adding at $pos $child\n" if $Tree::MultiNode::debug; unless ( $pos <= $#{$children} ) { my $num = $#{$children}; confess "Position $pos is invalid for child position [$num] $children.\n"; } splice( @{$children}, $pos, 1, $child, ${$children}[$pos] ); } else { print __PACKAGE__, "::add_child_node() adding at end $child\n" if $Tree::MultiNode::debug; push @{$children}, $child; } print __PACKAGE__, "::add_child_node() children:", join( ',', @{ $self->{'curr_node'}->children } ), "\n" if $Tree::MultiNode::debug; } =head2 Tree::MultiNode::Handle::depth Gets the depth for the current node. my $depth = $handle->depth(); =cut sub depth { my $self = shift; my $node = $self->{'curr_node'}; print __PACKAGE__, "::depth() getting depth \"$self->{'curr_depth'}\" ", "on: $node\n" if $Tree::MultiNode::debug; return $self->{'curr_depth'}; } =head2 Tree::MultiNode::Handle::select Sets the current child via a specified value -- basically it iterates through the array of children, looking for a match. You have to supply the key to look for, and optionally a sub ref to find it. The default for this sub is sub { return shift eq shift; } Which is sufficient for testing the equality of strings (the most common thing that I think will get stored in the tree). If you're storing multiple data types as keys, you'll have to write a sub that figures out how to perform the comparisons in a sane manner. The code reference should take two arguments, and compare them -- return false if they don't match, and true if they do. $handle->select('lname', sub { return shift eq shift; } ); =cut sub select { my $self = shift; my $key = shift; my $code = shift || sub { return shift eq shift; }; my ( $child, $pos ); my $found = undef; $pos = 0; foreach $child ( $self->children() ) { if ( $code->( $key, $child->key() ) ) { $self->{'curr_pos'} = $pos; $self->{'curr_child'} = $child; ++$found; last; } ++$pos; } return $found; } =head2 Tree::MultiNode::Handle::position Sets, or retrieves the current child position. print "curr child pos is: ", $handle->position(), "\n"; $handle->position(5); # sets the 6th child as the current child =cut sub position { my $self = shift; my $pos = shift; print __PACKAGE__, "::position() $self $pos\n" if $Tree::MultiNode::debug; unless ( defined $pos ) { return $self->{'curr_pos'}; } my $children = $self->{'curr_node'}->children; print __PACKAGE__, "::position() children: $children\n" if $Tree::MultiNode::debug; print __PACKAGE__, "::position() position is $pos ", $#{$children}, "\n" if $Tree::MultiNode::debug; unless ( $pos <= $#{$children} ) { my $num = $#{$children}; confess "Error, $pos is invalid [$num] $children.\n"; } $self->{'curr_pos'} = $pos; $self->{'curr_child'} = $self->get_child($pos); return $self->{'curr_pos'}; } =head2 Tree::MultiNode::Handle::first Tree::MultiNode::Handle::next Tree::MultiNode::Handle::prev Tree::MultiNode::Handle::last These functions manipulate the current child member. first() sets the first child as the current child, while last() sets the last. next(), and prev() will move to the next/prev child respectively. If there is no current child node, next() will have the same effect as first(), and prev() will operate as last(). prev() fails if the current child is the first child, and next() fails if the current child is the last child -- i.e., they do not wrap around. These functions will fail if there are no children for the current node. $handle->first(); # sets to the 0th child $handle->next(); # to the 1st child $handle->prev(); # back to the 0th child $handle->last(); # go straight to the last child. =cut sub first { my $self = shift; $self->{'curr_pos'} = 0; $self->{'curr_child'} = $self->get_child(0); print __PACKAGE__, "::first() set child[", $self->{'curr_pos'}, "]: ", $self->{'curr_child'}, "\n" if $Tree::MultiNode::debug; return $self->{'curr_pos'}; } sub next { my $self = shift; my $pos = $self->{'curr_pos'} + 1; my $children = $self->{'curr_node'}->children; print __PACKAGE__, "::next() children: $children\n" if $Tree::MultiNode::debug; unless ( $pos >= 0 && $pos <= $#{$children} ) { return undef; } $self->{'curr_pos'} = $pos; $self->{'curr_child'} = $self->get_child($pos); return $self->{'curr_pos'}; } sub prev { my $self = shift; my $pos = $self->{'curr_pos'} - 1; my $children = $self->{'curr_node'}->children; print __PACKAGE__, "::prev() children: $children\n" if $Tree::MultiNode::debug; unless ( $pos >= 0 && $pos <= $#{$children} ) { return undef; } $self->{'curr_pos'} = $pos; $self->{'curr_child'} = $self->get_child($pos); return $self->{'curr_pos'}; } sub last { my $self = shift; my $children = $self->{'curr_node'}->children; my $pos = $#{$children}; print __PACKAGE__, "::last() children [$pos]: $children\n" if $Tree::MultiNode::debug; $self->{'curr_pos'} = $pos; $self->{'curr_child'} = $self->get_child($pos); return $self->{'curr_pos'}; } =head2 Tree::MultiNode::Handle::down down() moves the handle to point at the current child node. It fails if there is no current child node. When down() is called, the current child becomes invalid (undef). $handle->down(); =cut sub down { my $self = shift; my $pos = shift; my $node = $self->{'curr_node'}; return undef unless defined $node; my $children = $node->children; print __PACKAGE__, "::down() children: $children\n" if $Tree::MultiNode::debug; if ( defined $pos ) { unless ( defined $self->position($pos) ) { confess "Error, $pos was an invalid position.\n"; } } $self->{'curr_pos'} = undef; $self->{'curr_node'} = $self->{'curr_child'}; $self->{'curr_child'} = undef; ++$self->{'curr_depth'}; print __PACKAGE__, "::down() set to: ", $self->{'curr_node'}, "\n" if $Tree::MultiNode::debug; return 1; } =head2 Tree::MultiNode::Handle::up down() moves the handle to point at the parent of the current node. It fails if there is no parent node. When up() is called, the current child becomes invalid (undef). $handle->up(); =cut sub up { my $self = shift; my $node = $self->{'curr_node'}; return undef unless defined $node; my $parent = $node->parent(); unless ( defined $parent ) { return undef; } $self->{'curr_pos'} = undef; $self->{'curr_node'} = $parent; $self->{'curr_child'} = undef; --$self->{'curr_depth'}; return 1; } =head2 Tree::MultiNode::Handle::top Resets the handle to point back at the top of the tree. When top() is called, the current child becomes invalid (undef). $handle->top(); =cut sub top { my $self = shift; my $tree = $self->{'tree'}; $self->{'curr_pos'} = undef; $self->{'curr_node'} = $tree->{'top'}; $self->{'curr_child'} = undef; $self->{'curr_depth'} = 0; return 1; } =head2 Tree::MultiNode::Handle::children This returns an array of Node objects that represents the children of the current Node. Unlike Node::children(), the array Handle::children() is not a reference to an array, but an array. Useful if you need to iterate through the children of the current node. print "There are: ", scalar($handle->children()), " children\n"; foreach $child ($handle->children()) { print $child->key(), " : ", $child->value(), "\n"; } =cut sub children { my $self = shift; my $node = $self->{'curr_node'}; return undef unless defined $node; my $children = $node->children; return @{$children}; } =head2 Tree::MultiNode::Handle::child_key_positions This function returns a hash table that consists of the child keys as the hash keys, and the position in the child array as the value. This allows for a quick and dirty way of looking up the position of a given key in the child list. my %h = $handle->child_key_positions(); =cut sub child_key_positions { my $self = shift; my $node = $self->{'curr_node'}; return $node->child_key_positions(); } =head2 Tree::MultiNode::Handle::get_child_key Returns the key at the specified position, or from the corresponding child node. my $key = $handle->get_child_key(); =cut sub get_child_key { my $self = shift; my $pos = shift; $pos = $self->{'curr_pos'} unless defined $pos; my $node = $self->get_child($pos); return defined $node ? $node->key() : undef; } =head2 Tree::MultiNode::Handle::get_child_value Returns the value at the specified position, or from the corresponding child node. my $value = $handle->get_child_value(); =cut sub get_child_value { my $self = shift; my $pos = shift || $self->{'curr_pos'}; print __PACKAGE__, "::sub get_child_value() pos is: $pos\n" if $Tree::MultiNode::debug; my $node = $self->get_child($pos); return defined $node ? $node->value() : undef; } =head2 Tree::MultiNode::Handle::remove_child Returns Tree::MultiNode::Node::child_kv_paris() for the current node for this handle. my %pairs = $handle->kv_pairs(); =cut sub kv_pairs { my $self = shift; my $node = $self->{'curr_node'}; return $node->child_kv_pairs(); } =head2 Tree::MultiNode::Handle::remove_child =cut sub remove_child { my $self = shift; my $pos = shift || $self->{'curr_pos'}; print __PACKAGE__, "::remove_child() pos is: $pos\n" if $Tree::MultiNode::debug; my $children = $self->{'curr_node'}->children; unless ( defined $children ) { return undef; } unless ( defined $pos && $pos >= 0 && $pos <= $#{$children} ) { my $num = $#{$children}; confess "Error, $pos is an invalid position [$num] $children.\n"; } my $node = splice( @{$children}, $pos, 1 ); return ( $node->key, $node->value ); } =head2 Tree::MultiNode::Handle::child_keys Returns the keys from the current node's children. Returns undef if there is no current node. =cut sub child_keys { my $self = shift; my $node = $self->{'curr_node'}; return undef unless $node; return $node->child_keys(); } =head2 Tree::MultiNode::Handle::traverse $handle->traverse(sub { my $h = pop; printf "%sk: %s v: %s\n",(' ' x $handle->depth()),$h->get_data(); }); Traverse takes a subroutine reference, and will visit each node of the tree, starting with the node the handle currently points to, recursively down from the current position of the handle. Each time the subroutine is called, it will be passed a handle which points to the node to be visited. Any additional arguments after the sub ref will be passed to the traverse function _before_ the handle is passed. This should allow you to pass constant arguments to the sub ref. Modifying the node that the handle points to will cause traverse to work from the new node forward. =cut sub traverse { my ( $self, $subref, @args ) = @_; confess "Error, invalid sub ref: $subref\n" unless 'CODE' eq ref($subref); # operate on a cloned handle return Tree::MultiNode::Handle->new($self)->_traverseImpl( $subref, @args ); } sub _traverseImpl { my ( $self, $subref, @args ) = @_; $subref->( @args, $self ); for ( my $i = 0; $i < scalar( $self->children ); ++$i ) { $self->down($i); $self->_traverseImpl( $subref, @args ); $self->up(); } return; } =head2 Tree::MultiNode::Handle::traverse or to have the subref to be a method on an object (and still pass the object's 'self' to the method). $handle->traverse( \&Some::Object::method, $obj, $const1, \%const2 ); ... sub method { my $handle = pop; my $self = shift; my $const1 = shift; my $const2 = shift; # do something } =cut sub otraverse { my ( $self, $subref, @args ) = @_; confess "Error, invalid sub ref: $subref\n" unless 'CODE' eq ref($subref); # operate on a cloned handle return Tree::MultiNode::Handle->new($self)->_otraverseImpl( $subref, @args ); } sub _otraverseImpl { my ( $self, $obj, $method, @args ) = @_; $obj->$method( @args, $self ); for ( my $i = 0; $i < scalar( $self->children ); ++$i ) { $self->down($i); $self->_otraverseImpl( $obj, $method, @args ); $self->up(); } return; } =head1 SEE ALSO Algorithms in C++ Robert Sedgwick Addison Wesley 1992 ISBN 0201510596 The Art of Computer Programming, Volume 1: Fundamental Algorithms, third edition, Donald E. Knuth =head1 AUTHORS Kyle R. Burton (initial version, and maintenence) Daniel X. Pape (see Changes file from the source archive) Eric Joanis Todd Rinaldo =head1 BUGS - There is currently no way to remove a child node. =cut 1; Tree-MultiNode-1.0.14/META.yml0000644000000000000000000000144014002477617014350 0ustar rootroot--- abstract: 'a multi-node tree object. Most useful for modeling hierarchical data structures.' author: - 'Kyle R. Burton ' build_requires: ExtUtils::MakeMaker: '0' Test::More: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Tree-MultiNode no_index: directory: - t - inc requires: Test::More: '0' resources: bugtracker: https://github.com/toddr/Tree-MultiNode/issues license: http://dev.perl.org/licenses/ repository: https://github.com/toddr/Tree-MultiNode version: v1.0.14 x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Tree-MultiNode-1.0.14/META.json0000644000000000000000000000243214002477620014514 0ustar rootroot{ "abstract" : "a multi-node tree object. Most useful for modeling hierarchical data structures.", "author" : [ "Kyle R. Burton " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Tree-MultiNode", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0", "Test::More" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Test::More" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/toddr/Tree-MultiNode/issues" }, "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "https://github.com/toddr/Tree-MultiNode" } }, "version" : "v1.0.14", "x_serialization_backend" : "JSON::PP version 4.04" }