Tree-MultiNode-2.02/ 000755 000765 000024 00000000000 15164614062 015763 5 ustar 00todd.rinaldo staff 000000 000000 Tree-MultiNode-2.02/INSTALL 000644 000765 000024 00000000531 15164101600 017000 0 ustar 00todd.rinaldo staff 000000 000000 Tree::MultiNode Installation Instructions
To install this module, run the following commands:
perl Makefile.PL
make
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.
Tree-MultiNode-2.02/LICENSE 000644 000765 000024 00000000614 15161552353 016772 0 ustar 00todd.rinaldo staff 000000 000000 This module is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
a) the GNU General Public License as published by the Free Software
Foundation; either version 1, or (at your option) any later version,
or
b) the "Artistic License" which comes with Perl.
For more details, see the full text of the licenses at
.
Tree-MultiNode-2.02/Changes 000644 000765 000024 00000017307 15164613043 017264 0 ustar 00todd.rinaldo staff 000000 000000 Revision history for Perl extension Tree::MultiNode.
2.02 2026-04-05
Bug Fixes:
- Fix next()/prev() crashing when curr_pos is undef, and fix otraverse
parameter handling. PR #7
- Fix first()/last() crashing on leaf nodes, and fix down() corrupting
handle state. GH #8, PR #8
- Fix Node::_clone deep cloning children instead of wrapping the arrayref,
which caused cloned trees to share child mutations. GH #9, PR #9
- Fix add_child_node destroying the caller's tree when merging, and add
validation for negative position arguments. GH #10, PR #10
- Fix circular reference memory leaks by using weak parent refs
(Scalar::Util::weaken). GH #21, PR #21
- Fix PREREQ_PM being silently overwritten on older ExtUtils::MakeMaker.
PR #31
Improvements:
- Add missing Handle::child_values() method. GH #23, PR #23
- Add num_children() method to Node and optimize traverse. PR #33
- Add use warnings to all packages. PR #15
- Modernize Perl pragmas and debug output style. PR #11
- Add edge case test coverage for Handle API behavioral contracts. PR #20
- Correct POD typo in up() method. PR #7
- Update INSTALL to match actual build system (Makefile.PL). PR #18
Maintenance:
- Split Node and Handle into separate module files. PR #28
- Split test suite into per-class test files (t/node.t, t/tree.t,
t/handle.t). PR #29
- Split bugfix tests into individual t/bugfix-*.t files. PR #34
- Remove unused variables and fix POD documentation. PR #30
- Correct CPAN metadata: Test::More as test dep, add MIN_PERL_VERSION
and provides. PR #13
- Update stale GitHub URLs in META_MERGE and skip CLAUDE.md from dist.
PR #12
- Add LICENSE, SECURITY, CONTRIBUTING files and update Makefile.PL
metadata. GH #14, PR #15
- Add CLAUDE.md with project conventions and generated file docs. PR #26
- Add Markdown README.md generated from POD.
2.01 2026-03-22
Bug Fixes:
- Fix remove_child(0) failing because position 0 is treated as falsy.
The same || bug affected get_child() and get_child_value().
Fixes GH #1 (rt.cpan.org #83606), PR #2
- Fix Node constructor losing falsy keys like 0 and "". The $key || undef
pattern dropped valid falsy values. PR #3
- Fix remove_child() leaving curr_pos and curr_child pointing at stale
data after removing a child node. PR #6
- Fix value() setter not accepting falsy values (0, "", undef) due to
using defined() instead of argument count check. PR #6
- Fix otraverse() POD heading incorrectly duplicating the traverse
heading. PR #6
Improvements:
- Add comprehensive test suite (t/02-comprehensive.t) covering 37
subtests across Node, Tree, and Handle packages. PR #4
- Fix stale POD: remove_child heading actually documented kv_pairs. PR #3
Maintenance:
- Modernize GitHub Actions CI workflow (Linux Perl 5.8–latest, macOS,
Windows). PR #5
- Update MANIFEST for new xt files
- Code tidying
- Add GitHub README
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-2.02/MANIFEST 000644 000765 000024 00000001410 15164614062 017110 0 ustar 00todd.rinaldo staff 000000 000000 Changes
CONTRIBUTING.md
INSTALL
lib/Tree/MultiNode.pm
lib/Tree/MultiNode/Handle.pm
lib/Tree/MultiNode/Node.pm
LICENSE
Makefile.PL
MANIFEST This list of files
MANIFEST.SKIP
README.md
SECURITY.md
t/00-load.t
t/01-multinode.t
t/04-edge-cases.t
t/bugfix-add-child-node.t
t/bugfix-down-no-child.t
t/bugfix-first-last-leaf.t
t/bugfix-negative-position.t
t/bugfix-next-prev-undef-pos.t
t/bugfix-node-clone-children.t
t/bugfix-node-key-falsy.t
t/bugfix-node-value-falsy.t
t/bugfix-otraverse.t
t/bugfix-remove-child-cursor.t
t/bugfix-weak-parent-refs.t
t/handle.t
t/node.t
t/tree.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-2.02/t/ 000755 000765 000024 00000000000 15164614062 016226 5 ustar 00todd.rinaldo staff 000000 000000 Tree-MultiNode-2.02/xt/ 000755 000765 000024 00000000000 15164614062 016416 5 ustar 00todd.rinaldo staff 000000 000000 Tree-MultiNode-2.02/README.md 000644 000765 000024 00000011467 15164613100 017243 0 ustar 00todd.rinaldo staff 000000 000000 # NAME
[](https://github.com/cpan-authors/Tree-MultiNode/actions/workflows/testsuite.yml)
Tree::MultiNode -- a multi-node tree object. Most useful for
modeling hierarchical data structures.
# SYNOPSIS
use Tree::MultiNode;
use strict;
use warnings;
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($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;
}
# 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.
## 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 = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
## 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.
## $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.
# API REFERENCE
## Tree::MultiNode
The tree object.
## 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 = Tree::MultiNode->new;
# 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
# AUTHORS
Kyle R. Burton (initial version, and maintenence)
Daniel X. Pape (see Changes file from the source archive)
Eric Joanis
Todd Rinaldo
# BUGS
Please report bugs via the issue tracker at
[https://github.com/cpan-authors/Tree-MultiNode/issues](https://github.com/cpan-authors/Tree-MultiNode/issues).
# LICENSE
This module is free software; you can redistribute it and/or modify it
under the same terms as Perl itself. See [perlartistic](https://metacpan.org/pod/perlartistic) and [perlgpl](https://metacpan.org/pod/perlgpl).
Tree-MultiNode-2.02/MANIFEST.SKIP 000644 000765 000024 00000000156 15161556132 017663 0 ustar 00todd.rinaldo staff 000000 000000 ^\.git
^MYMETA\.*
^MANIFEST\.bak$
^\.perltidyrc$
^Makefile$
^blib
^pm_to_blib
^.*\.bs
^cpanfile$
^CLAUDE\.md$
Tree-MultiNode-2.02/CONTRIBUTING.md 000644 000765 000024 00000001213 15161552353 020212 0 ustar 00todd.rinaldo staff 000000 000000 # Contributing to Tree::MultiNode
Thank you for your interest in contributing!
## How to Contribute
1. Fork the repository at .
2. Create a feature branch from `main`.
3. Make your changes and add tests where appropriate.
4. Run the test suite: `perl Makefile.PL && make test`
5. Submit a pull request.
## Reporting Bugs
Please report bugs via the issue tracker at
.
## Coding Guidelines
- Follow existing code style and conventions.
- Tests use `Test::More` with a declared plan.
- No external dependencies beyond core Perl and Test::More.
Tree-MultiNode-2.02/META.yml 000644 000765 000024 00000002073 15164614062 017236 0 ustar 00todd.rinaldo staff 000000 000000 ---
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.76, 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
provides:
Tree::MultiNode:
file: lib/Tree/MultiNode.pm
version: '2.02'
Tree::MultiNode::Handle:
file: lib/Tree/MultiNode/Handle.pm
version: '2.02'
Tree::MultiNode::Node:
file: lib/Tree/MultiNode/Node.pm
version: '2.02'
requires:
Scalar::Util: '0'
perl: '5.008'
resources:
bugtracker: https://github.com/cpan-authors/Tree-MultiNode/issues
license: http://dev.perl.org/licenses/
repository: https://github.com/cpan-authors/Tree-MultiNode.git
version: '2.02'
x_serialization_backend: 'CPAN::Meta::YAML version 0.020'
Tree-MultiNode-2.02/lib/ 000755 000765 000024 00000000000 15164614062 016531 5 ustar 00todd.rinaldo staff 000000 000000 Tree-MultiNode-2.02/Makefile.PL 000644 000765 000024 00000003610 15164613743 017742 0 ustar 00todd.rinaldo staff 000000 000000 use 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 => {},
MIN_PERL_VERSION => '5.008',
($ExtUtils::MakeMaker::VERSION >= 6.3002 ? ('LICENSE' => 'perl', ) : ()),
PREREQ_PM => {
'Scalar::Util' => 0,
($ExtUtils::MakeMaker::VERSION < 6.64 ? ('Test::More' => 0) : ()),
},
($ExtUtils::MakeMaker::VERSION >= 6.64 ? (
TEST_REQUIRES => {
'Test::More' => 0,
},
) : ()),
dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
clean => { FILES => 'Tree-MultiNode-*' },
META_MERGE => {
'meta-spec' => { version => 2 },
resources => {
license => ['http://dev.perl.org/licenses/'],
bugtracker => {
web => 'https://github.com/cpan-authors/Tree-MultiNode/issues',
},
repository => {
type => 'git',
url => 'https://github.com/cpan-authors/Tree-MultiNode.git',
web => 'https://github.com/cpan-authors/Tree-MultiNode',
},
},
provides => {
'Tree::MultiNode' => {
file => 'lib/Tree/MultiNode.pm',
version => MM->parse_version('lib/Tree/MultiNode.pm'),
},
'Tree::MultiNode::Node' => {
file => 'lib/Tree/MultiNode/Node.pm',
version => MM->parse_version('lib/Tree/MultiNode/Node.pm'),
},
'Tree::MultiNode::Handle' => {
file => 'lib/Tree/MultiNode/Handle.pm',
version => MM->parse_version('lib/Tree/MultiNode/Handle.pm'),
},
},
},
);
Tree-MultiNode-2.02/SECURITY.md 000644 000765 000024 00000000637 15161552353 017563 0 ustar 00todd.rinaldo staff 000000 000000 # Security Policy
## Reporting a Vulnerability
If you discover a security vulnerability in Tree::MultiNode, please report
it responsibly.
**Contact:** Todd Rinaldo
You may also file an issue at
if the
vulnerability is not sensitive.
We will acknowledge receipt within 72 hours and aim to provide a fix or
mitigation plan within 30 days.
Tree-MultiNode-2.02/META.json 000644 000765 000024 00000003525 15164614062 017411 0 ustar 00todd.rinaldo staff 000000 000000 {
"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.76, 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"
}
},
"configure" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"runtime" : {
"requires" : {
"Scalar::Util" : "0",
"perl" : "5.008"
}
},
"test" : {
"requires" : {
"Test::More" : "0"
}
}
},
"provides" : {
"Tree::MultiNode" : {
"file" : "lib/Tree/MultiNode.pm",
"version" : "2.02"
},
"Tree::MultiNode::Handle" : {
"file" : "lib/Tree/MultiNode/Handle.pm",
"version" : "2.02"
},
"Tree::MultiNode::Node" : {
"file" : "lib/Tree/MultiNode/Node.pm",
"version" : "2.02"
}
},
"release_status" : "stable",
"resources" : {
"bugtracker" : {
"web" : "https://github.com/cpan-authors/Tree-MultiNode/issues"
},
"license" : [
"http://dev.perl.org/licenses/"
],
"repository" : {
"type" : "git",
"url" : "https://github.com/cpan-authors/Tree-MultiNode.git",
"web" : "https://github.com/cpan-authors/Tree-MultiNode"
}
},
"version" : "2.02",
"x_serialization_backend" : "JSON::PP version 4.16"
}
Tree-MultiNode-2.02/lib/Tree/ 000755 000765 000024 00000000000 15164614062 017430 5 ustar 00todd.rinaldo staff 000000 000000 Tree-MultiNode-2.02/lib/Tree/MultiNode.pm 000644 000765 000024 00000012443 15164613050 021666 0 ustar 00todd.rinaldo staff 000000 000000
=head1 NAME
=for markdown [](https://github.com/cpan-authors/Tree-MultiNode/actions/workflows/testsuite.yml)
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 = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($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 = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($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 warnings;
use 5.008;
our $VERSION = '2.02';
our $debug;
use Tree::MultiNode::Node;
use Tree::MultiNode::Handle;
=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 = Tree::MultiNode->new;
=cut
sub new {
my $this = shift;
my $class = ref($this) || $this;
my $self = {};
bless $self, $class;
$self->{'top'} = Tree::MultiNode::Node->new();
return $self;
}
#
# With weak parent references, there are no circular references to break.
# Perl's reference counting handles cleanup naturally.
#
sub DESTROY {
my $self = shift;
delete $self->{'top'};
}
=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
Please report bugs via the issue tracker at
L.
=head1 LICENSE
This module is free software; you can redistribute it and/or modify it
under the same terms as Perl itself. See L and L.
=cut
1;
Tree-MultiNode-2.02/lib/Tree/MultiNode/ 000755 000765 000024 00000000000 15164614062 021330 5 ustar 00todd.rinaldo staff 000000 000000 Tree-MultiNode-2.02/lib/Tree/MultiNode/Handle.pm 000644 000765 000024 00000055424 15164613064 023074 0 ustar 00todd.rinaldo staff 000000 000000 package Tree::MultiNode::Handle;
use strict;
use warnings;
use Carp;
use Scalar::Util qw(weaken);
our $VERSION = '2.02';
sub _debug {
return unless $Tree::MultiNode::debug;
no warnings 'uninitialized';
print @_;
}
=head1 NAME
Tree::MultiNode::Handle -- a cursor for navigating a Tree::MultiNode tree.
=head1 DESCRIPTION
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 = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
=cut
sub new {
my $this = shift;
my $class = ref($this) || $this;
my $self = {};
bless $self, $class;
my $data = shift;
_debug(__PACKAGE__, "::new() ref($data) is: ", ref($data), "\n");
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;
_debug(__PACKAGE__, "::_clone() cloning: ", $them, "\n");
_debug(__PACKAGE__, "::_clone() depth: ", $them->{'curr_depth'}, "\n");
$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 = Tree::MultiNode::Handle->new($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();
_debug(__PACKAGE__, "::get_key() getting from ", $node, " : ", $key, "\n");
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'};
_debug(__PACKAGE__, "::set_key() setting key \"", $key, "\" on: ", $node, "\n");
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();
_debug(__PACKAGE__, "::get_value() getting from ", $node, " : ", $value, "\n");
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'};
_debug(__PACKAGE__, "::set_value() setting value \"", $value, "\" on: ", $node, "\n");
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;
$pos = defined $pos ? $pos : $self->{'curr_pos'};
_debug(__PACKAGE__, "::get_child() children: ", $children, " ", $pos, "\n");
unless ( defined $children ) {
return undef;
}
unless ( defined $pos && $pos <= $#{$children} ) {
my $num = $#{$children};
confess "Error, $pos is an invalid position [$num] $children.\n";
}
_debug(__PACKAGE__, "::get_child() returning [$pos]: ",
${$children}[$pos], "\n");
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;
_debug(__PACKAGE__, "::add_child() children: ", $children, "\n");
my $child = Tree::MultiNode::Node->new( $key, $value );
$child->{'parent'} = $self->{'curr_node'};
weaken($child->{'parent'});
_debug(__PACKAGE__, "::add_child() adding child ", $child, " (", $key, ",", $value, ") ",
"to: ", $children, "\n");
if ( defined $pos ) {
_debug(__PACKAGE__, "::add_child() adding at ", $pos, " ", $child, "\n");
unless ( $pos >= 0 && $pos <= $#{$children} ) {
my $num = $#{$children};
confess "Position $pos is invalid for child position [$num] $children.\n";
}
splice( @{$children}, $pos, 1, $child, ${$children}[$pos] );
}
else {
_debug(__PACKAGE__, "::add_child() adding at end ", $child, "\n");
push @{$children}, $child;
}
_debug(__PACKAGE__, "::add_child() children:",
join( ',', @{ $self->{'curr_node'}->children } ), "\n");
}
=head2 Tree::MultiNode::Handle::add_child_node
Adds an existing node (or the top node of another tree) as a child of the
current node. Works like C but accepts a pre-built
L or L object instead of a key/value
pair.
When a Tree::MultiNode (tree) object is passed, its top node is extracted
and added as a child. The original tree remains valid but now shares
structure with this tree -- the caller should not modify the original tree
after this call.
When a position is given, the new child is inserted before the existing
child at that position. Without a position, the child is appended to the
end.
# append an existing node as the last child
my $node = Tree::MultiNode::Node->new("color", "red");
$handle->add_child_node($node);
# insert at a specific position
$handle->add_child_node($node, 0); # insert as first child
# graft another tree's root node
my $other = Tree::MultiNode->new();
$handle->add_child_node($other);
=cut
sub add_child_node {
my $self = shift;
my ( $child, $pos ) = @_;
my $children = $self->{'curr_node'}->children;
_debug(__PACKAGE__, "::add_child_node() children: ", $children, "\n");
if ( ref($child) eq 'Tree::MultiNode' ) {
$child = $child->{'top'};
}
confess "Invalid child argument.\n"
if ( ref($child) ne 'Tree::MultiNode::Node' );
$child->{'parent'} = $self->{'curr_node'};
weaken($child->{'parent'});
_debug(__PACKAGE__, "::add_child_node() adding child ", $child,
" to: ", $children, "\n");
if ( defined $pos ) {
_debug(__PACKAGE__, "::add_child_node() adding at ", $pos, " ", $child, "\n");
unless ( $pos >= 0 && $pos <= $#{$children} ) {
my $num = $#{$children};
confess "Position $pos is invalid for child position [$num] $children.\n";
}
splice( @{$children}, $pos, 1, $child, ${$children}[$pos] );
}
else {
_debug(__PACKAGE__, "::add_child_node() adding at end ", $child, "\n");
push @{$children}, $child;
}
_debug(__PACKAGE__, "::add_child_node() children:",
join( ',', @{ $self->{'curr_node'}->children } ), "\n");
}
=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'};
_debug(__PACKAGE__, "::depth() getting depth \"", $self->{'curr_depth'}, "\" ",
"on: ", $node, "\n");
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;
_debug(__PACKAGE__, "::position() ", $self, " ", $pos, "\n");
unless ( defined $pos ) {
return $self->{'curr_pos'};
}
my $children = $self->{'curr_node'}->children;
_debug(__PACKAGE__, "::position() children: ", $children, "\n");
_debug(__PACKAGE__, "::position() position is $pos ",
$#{$children}, "\n");
unless ( $pos >= 0 && $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;
my $children = $self->{'curr_node'}->children;
unless ( defined $children && @{$children} ) {
return undef;
}
$self->{'curr_pos'} = 0;
$self->{'curr_child'} = $self->get_child(0);
_debug(__PACKAGE__, "::first() set child[", $self->{'curr_pos'}, "]: ",
$self->{'curr_child'}, "\n");
return $self->{'curr_pos'};
}
sub next {
my $self = shift;
my $children = $self->{'curr_node'}->children;
_debug(__PACKAGE__, "::next() children: ", $children, "\n");
# If no current child, behave like first() per documented contract
unless ( defined $self->{'curr_pos'} ) {
return $self->first();
}
my $pos = $self->{'curr_pos'} + 1;
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 $children = $self->{'curr_node'}->children;
_debug(__PACKAGE__, "::prev() children: ", $children, "\n");
# If no current child, behave like last() per documented contract
unless ( defined $self->{'curr_pos'} ) {
return $self->last();
}
my $pos = $self->{'curr_pos'} - 1;
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;
unless ( defined $children && @{$children} ) {
return undef;
}
my $pos = $#{$children};
_debug(__PACKAGE__, "::last() children [", $pos, "]: ", $children, "\n");
$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;
_debug(__PACKAGE__, "::down() children: ", $children, "\n");
if ( defined $pos ) {
unless ( defined $self->position($pos) ) {
confess "Error, $pos was an invalid position.\n";
}
}
# Prevent corrupting the handle when no child is selected
unless ( defined $self->{'curr_child'} ) {
return undef;
}
$self->{'curr_pos'} = undef;
$self->{'curr_node'} = $self->{'curr_child'};
$self->{'curr_child'} = undef;
++$self->{'curr_depth'};
_debug(__PACKAGE__, "::down() set to: ", $self->{'curr_node'}, "\n");
return 1;
}
=head2 Tree::MultiNode::Handle::up
up() 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::num_children
Returns the number of children for the current node. This is more
efficient than Cchildren())> because it does not
copy the children array.
my $count = $handle->num_children();
=cut
sub num_children {
my $self = shift;
return $self->{'curr_node'}->num_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;
$pos = defined $pos ? $pos : $self->{'curr_pos'};
_debug(__PACKAGE__, "::get_child_value() pos is: ", $pos, "\n");
my $node = $self->get_child($pos);
return defined $node ? $node->value() : undef;
}
=head2 Tree::MultiNode::Handle::kv_pairs
Returns Tree::MultiNode::Node::child_kv_pairs() 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
Removes the child at the specified position, or at the current child
position if no position is given. Returns the key and value of the
removed child node.
my ($key, $value) = $handle->remove_child(0);
=cut
sub remove_child {
my $self = shift;
my $pos = shift;
$pos = defined $pos ? $pos : $self->{'curr_pos'};
_debug(__PACKAGE__, "::remove_child() pos is: ", $pos, "\n");
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 );
$self->{'curr_node'}->{'children'} = $children;
# Reset handle's child cursor to avoid stale references
$self->{'curr_pos'} = undef;
$self->{'curr_child'} = undef;
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::child_values
Returns the values from the current node's children.
Returns undef if there is no current node.
=cut
sub child_values {
my $self = shift;
my $node = $self->{'curr_node'};
return undef unless $node;
return $node->child_values();
}
=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 );
my $num_children = $self->num_children();
for ( my $i = 0; $i < $num_children; ++$i ) {
$self->down($i);
$self->_traverseImpl( $subref, @args );
$self->up();
}
return;
}
=head2 Tree::MultiNode::Handle::otraverse
Like traverse(), but designed for passing an object method. The first
argument after the handle should be the object, the second should be
the method name or code reference, followed by any additional arguments.
The handle is passed as the last argument to the method.
This allows you to have the subref be a method on an object (and still
pass the object's 'self' to the method).
$handle->otraverse( $obj, \&Some::Object::method, $const1, \%const2 );
...
sub method
{
my $handle = pop;
my $self = shift;
my $const1 = shift;
my $const2 = shift;
# do something
}
=cut
sub otraverse {
my ( $self, $obj, $method, @args ) = @_;
confess "Error, invalid sub ref: $method\n" unless 'CODE' eq ref($method);
# operate on a cloned handle
return Tree::MultiNode::Handle->new($self)->_otraverseImpl( $obj, $method, @args );
}
sub _otraverseImpl {
my ( $self, $obj, $method, @args ) = @_;
$obj->$method( @args, $self );
my $num_children = $self->num_children();
for ( my $i = 0; $i < $num_children; ++$i ) {
$self->down($i);
$self->_otraverseImpl( $obj, $method, @args );
$self->up();
}
return;
}
1;
Tree-MultiNode-2.02/lib/Tree/MultiNode/Node.pm 000644 000765 000024 00000016146 15164613063 022563 0 ustar 00todd.rinaldo staff 000000 000000 package Tree::MultiNode::Node;
use strict;
use warnings;
use Carp;
use Scalar::Util qw(weaken);
our $VERSION = '2.02';
sub _debug {
return unless $Tree::MultiNode::debug;
no warnings 'uninitialized';
print @_;
}
=head1 NAME
Tree::MultiNode::Node -- a node in a Tree::MultiNode tree.
=head1 DESCRIPTION
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.
=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 = Tree::MultiNode::Node->new($oldNode);
# or
my $node = $oldNode->new();
# create a new node
my $node = Tree::MultiNode::Node->new;
my $node = Tree::MultiNode::Node->new("fname");
my $node = Tree::MultiNode::Node->new("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;
_debug(__PACKAGE__, "::new() key,val = ", $key, ",", $value, "\n");
$self->{'children'} = [];
$self->{'parent'} = undef;
$self->{'key'} = defined $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;
weaken($self->{'parent'}) if defined $self->{'parent'};
$self->{'key'} = $them->key;
$self->{'value'} = $them->value;
# Deep clone children so the copy is fully independent
$self->{'children'} = [];
foreach my $child ( @{$them->children} ) {
my $copy = Tree::MultiNode::Node->new($child);
$copy->{'parent'} = $self;
weaken($copy->{'parent'});
push @{$self->{'children'}}, $copy;
}
}
=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 ) {
_debug(__PACKAGE__, "::key() setting key: ", $key, " on ", $self, "\n");
$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 (including undef and other falsy values like
0 or ""). The value of the value member is always returned.
print $node3->value(), "\n"; # 'Larry'
$node3->value(0); # sets value to 0
$node3->value(undef); # sets value to undef
=cut
sub value {
my ( $self, $value ) = @_;
if ( @_ > 1 ) {
_debug(__PACKAGE__, "::value() setting value: ", $value, " on ", $self, "\n");
$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 = $node->child_keys();
my @vals = $node->child_values();
my %kv_pairs = $node->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::num_children
Returns the number of children for this node.
my $count = $node->num_children();
=cut
sub num_children {
my $self = shift;
return scalar @{$self->{'children'}};
}
=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;
no warnings 'uninitialized';
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'};
my $children = $self->{'children'};
if ( defined $children ) {
foreach my $child ( @{$children} ) {
$child->_clearrefs() if defined $child;
}
}
delete $self->{'children'};
}
1;
Tree-MultiNode-2.02/xt/98-pod-coverage.t 000644 000765 000024 00000001047 15160067036 021415 0 ustar 00todd.rinaldo staff 000000 000000 use 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-2.02/xt/99-pod.t 000644 000765 000024 00000000350 15160067036 017621 0 ustar 00todd.rinaldo staff 000000 000000 #!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-2.02/t/bugfix-next-prev-undef-pos.t 000644 000765 000024 00000005447 15164612364 023540 0 ustar 00todd.rinaldo staff 000000 000000 #!perl -T
use strict;
use warnings;
use Test::More;
use Tree::MultiNode;
# Bug fix: next() with undef curr_pos should behave like first()
# Bug fix: prev() with undef curr_pos should behave like last()
subtest 'next() with undef curr_pos behaves like first()' => sub {
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("a", 1);
$handle->add_child("b", 2);
$handle->add_child("c", 3);
# After construction, curr_pos is undef
is($handle->position(), undef, 'curr_pos starts undef');
# next() should behave like first() when curr_pos is undef
is($handle->next(), 0, 'next() with undef curr_pos returns 0 (like first)');
is($handle->get_child_key(), "a", 'current child is first child after next()');
};
subtest 'prev() with undef curr_pos behaves like last()' => sub {
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("a", 1);
$handle->add_child("b", 2);
$handle->add_child("c", 3);
# curr_pos is undef
is($handle->position(), undef, 'curr_pos starts undef');
# prev() should behave like last() when curr_pos is undef
is($handle->prev(), 2, 'prev() with undef curr_pos returns last index (like last)');
is($handle->get_child_key(), "c", 'current child is last child after prev()');
};
subtest 'next() after down() resets to first child' => sub {
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("child1", 1);
$handle->add_child("child2", 2);
# Navigate down into first child
$handle->first();
$handle->down();
# After down(), curr_pos is undef — add grandchildren
$handle->add_child("gc1", 10);
$handle->add_child("gc2", 20);
# next() should behave like first() since curr_pos is undef after down()
is($handle->next(), 0, 'next() after down() acts like first()');
is($handle->get_child_key(), "gc1", 'positioned at first grandchild');
};
subtest 'prev() after up() resets to last child' => sub {
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("child1", 1);
$handle->add_child("child2", 2);
$handle->add_child("child3", 3);
# Navigate down and back up to reset curr_pos
$handle->first();
$handle->down();
$handle->up();
# After up(), curr_pos is undef
is($handle->position(), undef, 'curr_pos is undef after up()');
# prev() should behave like last()
is($handle->prev(), 2, 'prev() after up() acts like last()');
is($handle->get_child_key(), "child3", 'positioned at last child');
};
done_testing;
Tree-MultiNode-2.02/t/bugfix-remove-child-cursor.t 000644 000765 000024 00000004237 15164612364 023577 0 ustar 00todd.rinaldo staff 000000 000000 #!perl -T
use strict;
use warnings;
use Test::More;
use Tree::MultiNode;
# Bug fix: remove_child must reset curr_pos/curr_child on the handle
subtest 'remove_child resets handle cursor state' => sub {
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("a", 1);
$handle->add_child("b", 2);
$handle->add_child("c", 3);
# Position at child 1 ("b")
$handle->position(1);
is($handle->get_child_key(), "b", 'positioned at child b');
# Remove child at position 0 ("a")
my ($key, $val) = $handle->remove_child(0);
is($key, "a", 'removed child key is a');
is($val, 1, 'removed child value is 1');
# After removal, handle cursor should be reset
is($handle->position(), undef, 'curr_pos is undef after remove_child');
};
subtest 'remove_child at current position resets cursor' => sub {
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("x", 10);
$handle->add_child("y", 20);
$handle->first();
is($handle->get_child_key(), "x", 'positioned at child x');
# Remove current child
my ($key, $val) = $handle->remove_child();
is($key, "x", 'removed correct child');
is($val, 10, 'removed correct value');
# Cursor should be reset
is($handle->position(), undef, 'curr_pos reset after removing current child');
# Should still have one child left
is(scalar($handle->children()), 1, 'one child remaining');
};
subtest 'remove_child then navigate works correctly' => sub {
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("a", 1);
$handle->add_child("b", 2);
$handle->add_child("c", 3);
# Remove middle child
$handle->remove_child(1);
# Re-navigate: should work fine with 2 remaining children
$handle->first();
is($handle->get_child_key(), "a", 'first child is a after removal');
$handle->next();
is($handle->get_child_key(), "c", 'second child is c (b was removed)');
};
done_testing;
Tree-MultiNode-2.02/t/bugfix-first-last-leaf.t 000644 000765 000024 00000002142 15164612364 022674 0 ustar 00todd.rinaldo staff 000000 000000 #!perl -T
use strict;
use warnings;
use Test::More;
use Tree::MultiNode;
# Bug fix: first()/last() crash on leaf nodes (no children)
subtest 'first() returns undef on leaf node' => sub {
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("leaf");
is(scalar($handle->children()), 0, 'node has no children');
is($handle->first(), undef, 'first() returns undef on leaf node');
};
subtest 'last() returns undef on leaf node' => sub {
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("leaf");
is(scalar($handle->children()), 0, 'node has no children');
is($handle->last(), undef, 'last() returns undef on leaf node');
};
subtest 'first() still works normally with children' => sub {
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->add_child("a", 1);
$handle->add_child("b", 2);
is($handle->first(), 0, 'first() returns 0');
is($handle->get_child_key(), "a", 'first child is a');
};
done_testing;
Tree-MultiNode-2.02/t/bugfix-node-value-falsy.t 000644 000765 000024 00000002222 15164612364 023051 0 ustar 00todd.rinaldo staff 000000 000000 #!perl -T
use strict;
use warnings;
use Test::More;
use Tree::MultiNode;
# Bug fix: Node::value() should accept falsy values including undef
subtest 'Node::value() accepts 0' => sub {
my $node = Tree::MultiNode::Node->new("count", 42);
is($node->value(), 42, 'initial value is 42');
$node->value(0);
is($node->value(), 0, 'value set to 0');
};
subtest 'Node::value() accepts empty string' => sub {
my $node = Tree::MultiNode::Node->new("name", "Larry");
is($node->value(), "Larry", 'initial value is Larry');
$node->value("");
is($node->value(), "", 'value set to empty string');
};
subtest 'Node::value() accepts undef' => sub {
my $node = Tree::MultiNode::Node->new("key", "val");
is($node->value(), "val", 'initial value is val');
$node->value(undef);
is($node->value(), undef, 'value set to undef via value()');
};
subtest 'Node::value() getter returns without setting' => sub {
my $node = Tree::MultiNode::Node->new("k", "original");
is($node->value(), "original", 'getter does not modify value');
is($node->value(), "original", 'calling getter again still returns original');
};
done_testing;
Tree-MultiNode-2.02/t/bugfix-otraverse.t 000644 000765 000024 00000002045 15164612364 021713 0 ustar 00todd.rinaldo staff 000000 000000 #!perl -T
use strict;
use warnings;
use Test::More;
use Tree::MultiNode;
# otraverse: verify it works correctly with object + method pattern
subtest 'otraverse calls method on object for each node' => sub {
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->set_value("r");
$handle->add_child("a", 1);
$handle->add_child("b", 2);
$handle->first();
$handle->down();
$handle->add_child("a1", 11);
$handle->top();
# Collector object to accumulate visited keys
my $collector = bless { keys => [] }, 'TestCollector';
no strict 'refs';
*TestCollector::collect = sub {
my $self = shift;
my $handle = pop;
push @{$self->{keys}}, $handle->get_key();
};
use strict 'refs';
$handle->otraverse($collector, \&TestCollector::collect);
is_deeply(
$collector->{keys},
[qw(root a a1 b)],
'otraverse visits all nodes in correct order via object method'
);
};
done_testing;
Tree-MultiNode-2.02/t/bugfix-node-clone-children.t 000644 000765 000024 00000007144 15164612364 023517 0 ustar 00todd.rinaldo staff 000000 000000 #!perl -T
use strict;
use warnings;
use Test::More;
use Tree::MultiNode;
# Bug fix: Node::_clone children array was wrapped instead of copied
subtest 'Node::_clone preserves children correctly' => sub {
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("a", 1);
$handle->add_child("b", 2);
$handle->add_child("c", 3);
my $original = $handle->{'curr_node'};
my $clone = Tree::MultiNode::Node->new($original);
# Clone should have same number of children as original
my $orig_children = $original->children;
my $clone_children = $clone->children;
is(scalar @$clone_children, scalar @$orig_children,
'clone has same number of children as original');
is(scalar @$clone_children, 3, 'clone has 3 children');
# Each child should be a Node, not a nested array ref
for my $i (0 .. $#{$clone_children}) {
is(ref($clone_children->[$i]), 'Tree::MultiNode::Node',
"clone child $i is a Node object");
}
# Children should have correct keys
is($clone_children->[0]->key(), "a", 'clone child 0 key is a');
is($clone_children->[1]->key(), "b", 'clone child 1 key is b');
is($clone_children->[2]->key(), "c", 'clone child 2 key is c');
};
subtest 'Node::_clone children point to clone as parent' => sub {
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("x", 10);
$handle->add_child("y", 20);
my $original = $handle->{'curr_node'};
my $clone = Tree::MultiNode::Node->new($original);
my $clone_children = $clone->children;
for my $i (0 .. $#{$clone_children}) {
is($clone_children->[$i]->parent(), $clone,
"clone child $i parent points to clone, not original");
}
};
subtest 'Node::_clone creates fully independent deep copy' => sub {
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("a", 1);
$handle->add_child("b", 2);
my $original = $handle->{'curr_node'};
my $clone = Tree::MultiNode::Node->new($original);
# Modifying clone's children should not affect original
$clone->children->[0]->key("CHANGED");
is($original->children->[0]->key(), "a",
'modifying clone child does not affect original');
# Adding to clone's children array should not affect original
my $new_child = Tree::MultiNode::Node->new("z", 99);
push @{$clone->children}, $new_child;
is(scalar @{$original->children}, 2, 'original still has 2 children');
is(scalar @{$clone->children}, 3, 'clone now has 3 children');
};
subtest 'Node::_clone with no children' => sub {
my $node = Tree::MultiNode::Node->new("leaf", "val");
my $clone = Tree::MultiNode::Node->new($node);
is($clone->key(), "leaf", 'cloned key');
is($clone->value(), "val", 'cloned value');
is(scalar @{$clone->children}, 0, 'clone has empty children array');
};
subtest 'Node::_clone parent refs are weak' => sub {
require Scalar::Util;
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("child", 1);
my $original = $handle->{'curr_node'};
my $clone = Tree::MultiNode::Node->new($original);
my $clone_children = $clone->children;
for my $i (0 .. $#{$clone_children}) {
ok(Scalar::Util::isweak($clone_children->[$i]->{'parent'}),
"clone child $i parent ref is weak");
}
};
done_testing;
Tree-MultiNode-2.02/t/node.t 000644 000765 000024 00000006254 15164612364 017352 0 ustar 00todd.rinaldo staff 000000 000000 #!perl -T
use strict;
use warnings;
use Test::More;
use Tree::MultiNode;
# ============================================================================
# Tree::MultiNode::Node tests
# ============================================================================
subtest 'Node construction - empty' => sub {
my $node = Tree::MultiNode::Node->new();
isa_ok($node, 'Tree::MultiNode::Node');
is($node->key(), undef, 'empty node has undef key');
is($node->value(), undef, 'empty node has undef value');
is(ref($node->children()), 'ARRAY', 'empty node has children array');
is(scalar @{$node->children()}, 0, 'empty node has no children');
is($node->parent(), undef, 'empty node has no parent');
};
subtest 'Node construction - with key and value' => sub {
my $node = Tree::MultiNode::Node->new("name", "Larry");
is($node->key(), "name", 'key set on construction');
is($node->value(), "Larry", 'value set on construction');
};
subtest 'Node construction - cloning' => sub {
my $orig = Tree::MultiNode::Node->new("color", "blue");
my $clone = Tree::MultiNode::Node->new($orig);
isa_ok($clone, 'Tree::MultiNode::Node');
is($clone->key(), "color", 'cloned key');
is($clone->value(), "blue", 'cloned value');
};
subtest 'Node key/value setters' => sub {
my $node = Tree::MultiNode::Node->new();
is($node->key("hello"), "hello", 'key setter returns new key');
is($node->key(), "hello", 'key getter returns set key');
is($node->value("world"), "world", 'value setter returns new value');
is($node->value(), "world", 'value getter returns set value');
};
subtest 'Node clear_key / clear_value' => sub {
my $node = Tree::MultiNode::Node->new("k", "v");
my $old_key = $node->clear_key();
is($old_key, "k", 'clear_key returns old key');
is($node->key(), undef, 'key is undef after clear');
my $old_val = $node->clear_value();
is($old_val, "v", 'clear_value returns old value');
is($node->value(), undef, 'value is undef after clear');
};
subtest 'Node child_keys / child_values / child_kv_pairs' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->add_child("x", 10);
$handle->add_child("y", 20);
$handle->add_child("z", 30);
my $node = $handle->{'curr_node'};
my @keys = $node->child_keys();
is_deeply(\@keys, ["x", "y", "z"], 'child_keys returns all keys in order');
my @vals = $node->child_values();
is_deeply(\@vals, [10, 20, 30], 'child_values returns all values in order');
my %kv = $node->child_kv_pairs();
is_deeply(\%kv, {x => 10, y => 20, z => 30}, 'child_kv_pairs returns hash');
};
subtest 'Node child_key_positions' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->add_child("alpha", 1);
$handle->add_child("beta", 2);
$handle->add_child("gamma", 3);
my $node = $handle->{'curr_node'};
my %pos = $node->child_key_positions();
is($pos{'alpha'}, 0, 'alpha at position 0');
is($pos{'beta'}, 1, 'beta at position 1');
is($pos{'gamma'}, 2, 'gamma at position 2');
};
done_testing();
Tree-MultiNode-2.02/t/tree.t 000644 000765 000024 00000001513 15164612364 017355 0 ustar 00todd.rinaldo staff 000000 000000 #!perl -T
use strict;
use warnings;
use Test::More;
use Tree::MultiNode;
# ============================================================================
# Tree::MultiNode construction / destruction
# ============================================================================
subtest 'Tree construction' => sub {
my $tree = Tree::MultiNode->new;
isa_ok($tree, 'Tree::MultiNode');
isa_ok($tree->{'top'}, 'Tree::MultiNode::Node');
};
subtest 'Tree destruction clears refs' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->add_child("a", 1);
$handle->add_child("b", 2);
$handle->down(0);
$handle->add_child("deep", "val");
# Just verify DESTROY doesn't crash
$tree->DESTROY();
pass('DESTROY completed without error');
};
done_testing();
Tree-MultiNode-2.02/t/00-load.t 000644 000765 000024 00000000236 15160067036 017547 0 ustar 00todd.rinaldo staff 000000 000000 #!perl -T
use Test::More tests => 1;
BEGIN {
use_ok( 'Tree::MultiNode' );
}
diag( "Testing Tree::MultiNode $Tree::MultiNode::VERSION, Perl $], $^X" );
Tree-MultiNode-2.02/t/04-edge-cases.t 000644 000765 000024 00000034632 15164612364 020647 0 ustar 00todd.rinaldo staff 000000 000000 #!perl -T
use strict;
use warnings;
use Test::More;
use Tree::MultiNode;
# ============================================================================
# Falsy keys and values through the full Handle API
# ============================================================================
subtest 'add_child with key 0 and value 0' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child(0, 0);
$handle->add_child(1, 1);
$handle->first();
is($handle->get_child_key(), 0, 'child key 0 retrievable');
is($handle->get_child_value(), 0, 'child value 0 retrievable');
};
subtest 'add_child with empty string key and value' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("", "");
$handle->add_child("nonempty", "val");
$handle->first();
is($handle->get_child_key(), "", 'child key empty string retrievable');
is($handle->get_child_value(), "", 'child value empty string retrievable');
};
subtest 'set_key and set_value with falsy values' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
is($handle->set_key(0), 0, 'set_key(0) returns 0');
is($handle->get_key(), 0, 'get_key returns 0');
is($handle->set_key(""), "", 'set_key("") returns empty string');
is($handle->get_key(), "", 'get_key returns empty string');
is($handle->set_value(0), 0, 'set_value(0) returns 0');
is($handle->get_value(), 0, 'get_value returns 0');
is($handle->set_value(""), "", 'set_value("") returns empty string');
is($handle->get_value(), "", 'get_value returns empty string');
};
subtest 'child_keys includes falsy keys' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child(0, "zero");
$handle->add_child("", "empty");
$handle->add_child("a", "alpha");
my @keys = $handle->child_keys();
is(scalar @keys, 3, 'three child keys returned');
is($keys[0], 0, 'first key is 0');
is($keys[1], "", 'second key is empty string');
is($keys[2], "a", 'third key is a');
};
subtest 'kv_pairs with falsy keys' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child(0, "zero_val");
$handle->add_child("", "empty_val");
$handle->add_child("k", "normal");
my %pairs = $handle->kv_pairs();
is($pairs{0}, "zero_val", 'kv_pairs includes key 0');
is($pairs{""}, "empty_val", 'kv_pairs includes empty string key');
is($pairs{"k"}, "normal", 'kv_pairs includes normal key');
};
subtest 'child_key_positions with falsy keys' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child(0, "zero");
$handle->add_child("", "empty");
$handle->add_child("a", "alpha");
my %pos = $handle->child_key_positions();
is($pos{0}, 0, 'position of key 0 is 0');
is($pos{""}, 1, 'position of empty string key is 1');
is($pos{"a"}, 2, 'position of key a is 2');
};
# ============================================================================
# select() edge cases
# ============================================================================
subtest 'select returns undef when no match' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("a", 1);
$handle->add_child("b", 2);
my $found = $handle->select("nonexistent");
is($found, undef, 'select returns undef for missing key');
};
subtest 'select returns undef on node with no children' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("leaf");
my $found = $handle->select("anything");
is($found, undef, 'select returns undef when no children');
};
subtest 'select with falsy key 0' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child(0, "zero");
$handle->add_child(1, "one");
my $found = $handle->select(0);
ok($found, 'select finds key 0');
is($handle->get_child_key(), 0, 'selected child has key 0');
};
subtest 'select sets curr_pos and curr_child' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("x", 10);
$handle->add_child("y", 20);
$handle->add_child("z", 30);
$handle->select("y");
is($handle->position(), 1, 'select set curr_pos to 1');
is($handle->get_child_key(), "y", 'select set curr_child correctly');
# Can navigate down to selected child
$handle->down();
is($handle->get_key(), "y", 'navigated down to selected child');
is($handle->get_value(), 20, 'selected child has correct value');
};
# ============================================================================
# traverse edge cases
# ============================================================================
subtest 'traverse on leaf node visits only that node' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("leaf");
$handle->set_value("alone");
my @visited;
$handle->traverse(sub {
my $h = pop;
push @visited, $h->get_key();
});
is(scalar @visited, 1, 'traverse visited exactly one node');
is($visited[0], "leaf", 'traverse visited the leaf');
};
subtest 'traverse does not modify original handle position' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("a", 1);
$handle->add_child("b", 2);
$handle->first();
$handle->down();
is($handle->get_key(), "a", 'handle at child a before traverse');
# Traverse from child a
my @visited;
$handle->traverse(sub {
my $h = pop;
push @visited, $h->get_key();
});
# Handle should still be at "a"
is($handle->get_key(), "a", 'handle still at child a after traverse');
is($handle->depth(), 1, 'handle depth unchanged after traverse');
};
subtest 'traverse passes extra args before handle' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
my @captured;
$handle->traverse(sub {
my $h = pop;
push @captured, [@_];
}, "arg1", "arg2");
is(scalar @captured, 1, 'visited one node');
is_deeply($captured[0], ["arg1", "arg2"], 'extra args passed correctly');
};
# ============================================================================
# Handle independence — two handles, one tree
# ============================================================================
subtest 'two handles navigate independently' => sub {
my $tree = Tree::MultiNode->new;
my $h1 = Tree::MultiNode::Handle->new($tree);
$h1->set_key("root");
$h1->add_child("left", "L");
$h1->add_child("right", "R");
my $h2 = Tree::MultiNode::Handle->new($tree);
# h1 goes left
$h1->first();
$h1->down();
is($h1->get_key(), "left", 'h1 at left child');
is($h1->depth(), 1, 'h1 depth is 1');
# h2 should still be at root
is($h2->get_key(), "root", 'h2 still at root');
is($h2->depth(), 0, 'h2 depth is 0');
# h2 goes right
$h2->last();
$h2->down();
is($h2->get_key(), "right", 'h2 at right child');
# h1 still at left
is($h1->get_key(), "left", 'h1 still at left child');
};
subtest 'cloned handle starts at same position' => sub {
my $tree = Tree::MultiNode->new;
my $h1 = Tree::MultiNode::Handle->new($tree);
$h1->set_key("root");
$h1->add_child("child", "val");
$h1->first();
$h1->down();
my $h2 = Tree::MultiNode::Handle->new($h1);
is($h2->get_key(), "child", 'cloned handle at same node');
is($h2->depth(), 1, 'cloned handle has same depth');
# Navigate clone independently
$h2->up();
is($h2->get_key(), "root", 'clone moved to root');
is($h1->get_key(), "child", 'original still at child');
};
# ============================================================================
# Node::dump smoke test
# ============================================================================
subtest 'Node::dump does not crash' => sub {
my $node = Tree::MultiNode::Node->new("k", "v");
# dump() prints to STDOUT — capture it
my $output = '';
{
local *STDOUT;
open STDOUT, '>', \$output or die "Can't redirect STDOUT: $!";
$node->dump();
}
like($output, qr/\[dump\]/, 'dump produces output');
like($output, qr/k/, 'dump includes key');
like($output, qr/v/, 'dump includes value');
pass('dump did not crash');
};
subtest 'Node::dump with undef key and value' => sub {
my $node = Tree::MultiNode::Node->new();
my $output = '';
{
local *STDOUT;
open STDOUT, '>', \$output or die "Can't redirect STDOUT: $!";
$node->dump();
}
like($output, qr/\[dump\]/, 'dump produces output with undef members');
pass('dump with undef members did not crash');
};
# ============================================================================
# child_kv_pairs with duplicate keys — hash semantics
# ============================================================================
subtest 'child_kv_pairs last value wins for duplicate keys' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("dup", "first");
$handle->add_child("dup", "second");
$handle->add_child("unique", "val");
my %pairs = $handle->kv_pairs();
is($pairs{"dup"}, "second", 'last value wins for duplicate key');
is($pairs{"unique"}, "val", 'unique key preserved');
};
# ============================================================================
# Misc behavioral contracts
# ============================================================================
subtest 'add_child to different levels builds correct tree' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
# Level 1
$handle->add_child("L1-a", "1a");
$handle->add_child("L1-b", "1b");
# Level 2 under L1-a
$handle->first();
$handle->down();
$handle->add_child("L2-a1", "2a1");
# Back up, go to L1-b, add children
$handle->up();
$handle->last();
$handle->down();
$handle->add_child("L2-b1", "2b1");
$handle->add_child("L2-b2", "2b2");
# Traverse and collect all nodes
$handle->top();
my @nodes;
$handle->traverse(sub {
my $h = pop;
push @nodes, $h->get_key();
});
is(scalar @nodes, 6, 'tree has 6 nodes total');
is($nodes[0], "root", 'root visited first');
# Depth-first: root -> L1-a -> L2-a1 -> L1-b -> L2-b1 -> L2-b2
is($nodes[1], "L1-a", 'L1-a second');
is($nodes[2], "L2-a1", 'L2-a1 third');
is($nodes[3], "L1-b", 'L1-b fourth');
is($nodes[4], "L2-b1", 'L2-b1 fifth');
is($nodes[5], "L2-b2", 'L2-b2 sixth');
};
subtest 'get_child_key and get_child_value at explicit position' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("a", 10);
$handle->add_child("b", 20);
$handle->add_child("c", 30);
# Access by explicit position without setting curr_pos
is($handle->get_child_key(0), "a", 'key at position 0');
is($handle->get_child_key(2), "c", 'key at position 2');
is($handle->get_child_value(1), 20, 'value at position 1');
# curr_pos should still be undef (explicit pos doesn't change it)
is($handle->position(), undef, 'curr_pos unchanged by explicit get_child_key');
};
subtest 'top resets depth to 0' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("a", 1);
$handle->first();
$handle->down();
$handle->add_child("b", 2);
$handle->first();
$handle->down();
is($handle->depth(), 2, 'at depth 2');
$handle->top();
is($handle->depth(), 0, 'top resets depth to 0');
is($handle->get_key(), "root", 'top resets to root node');
};
# ============================================================================
# num_children
# ============================================================================
subtest 'Node::num_children' => sub {
my $node = Tree::MultiNode::Node->new("root", "val");
is($node->num_children(), 0, 'new node has 0 children');
my $child1 = Tree::MultiNode::Node->new("a", 1);
push @{$node->children}, $child1;
is($node->num_children(), 1, 'after adding one child');
my $child2 = Tree::MultiNode::Node->new("b", 2);
push @{$node->children}, $child2;
is($node->num_children(), 2, 'after adding two children');
};
subtest 'Handle::num_children' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
is($handle->num_children(), 0, 'root starts with 0 children');
$handle->add_child("a", 1);
is($handle->num_children(), 1, 'after add_child: 1 child');
$handle->add_child("b", 2);
$handle->add_child("c", 3);
is($handle->num_children(), 3, 'after 3 add_child calls');
# navigate down and check leaf
$handle->first();
$handle->down();
is($handle->num_children(), 0, 'leaf node has 0 children');
# add grandchildren and verify
$handle->add_child("x", 10);
$handle->add_child("y", 20);
is($handle->num_children(), 2, 'after adding grandchildren');
# go back up
$handle->up();
is($handle->num_children(), 3, 'parent still has 3 children');
};
subtest 'num_children consistent with scalar children' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
for my $i (0..4) {
$handle->add_child("child$i", $i);
}
is($handle->num_children(), scalar($handle->children()),
'num_children agrees with scalar children');
};
done_testing;
Tree-MultiNode-2.02/t/handle.t 000644 000765 000024 00000036472 15164612364 017665 0 ustar 00todd.rinaldo staff 000000 000000 #!perl -T
use strict;
use warnings;
use Test::More;
use Tree::MultiNode;
# ============================================================================
# Handle construction and cloning
# ============================================================================
subtest 'Handle construction requires tree' => sub {
eval { Tree::MultiNode::Handle->new("not a tree") };
like($@, qr/invalid Tree::MultiNode reference/i, 'dies with bad argument');
};
subtest 'Handle cloning' => sub {
my $tree = Tree::MultiNode->new;
my $h1 = Tree::MultiNode::Handle->new($tree);
$h1->set_key("root");
$h1->set_value("val");
$h1->add_child("c1", 1);
$h1->first();
$h1->down();
my $h2 = Tree::MultiNode::Handle->new($h1);
isa_ok($h2, 'Tree::MultiNode::Handle');
is($h2->get_key(), "c1", 'cloned handle at same position');
is($h2->depth(), 1, 'cloned handle has correct depth');
};
# ============================================================================
# Handle navigation: first, next, prev, last
# ============================================================================
subtest 'first / next / prev / last navigation' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->add_child("a", 1);
$handle->add_child("b", 2);
$handle->add_child("c", 3);
$handle->add_child("d", 4);
is($handle->first(), 0, 'first() returns 0');
is($handle->get_child_key(), "a", 'first child is a');
is($handle->next(), 1, 'next() returns 1');
is($handle->get_child_key(), "b", 'second child is b');
is($handle->next(), 2, 'next() returns 2');
is($handle->get_child_key(), "c", 'third child is c');
is($handle->next(), 3, 'next() returns 3');
is($handle->get_child_key(), "d", 'fourth child is d');
is($handle->next(), undef, 'next() past end returns undef');
is($handle->last(), 3, 'last() returns 3');
is($handle->get_child_key(), "d", 'last child is d');
is($handle->prev(), 2, 'prev() returns 2');
is($handle->get_child_key(), "c", 'prev child is c');
is($handle->prev(), 1, 'prev() returns 1');
is($handle->prev(), 0, 'prev() returns 0');
is($handle->prev(), undef, 'prev() before start returns undef');
};
# ============================================================================
# Handle: up / down / top / depth
# ============================================================================
subtest 'down / up / top / depth tracking' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("L1", "v1");
is($handle->depth(), 0, 'depth at root is 0');
$handle->first();
$handle->down();
is($handle->depth(), 1, 'depth after down is 1');
is($handle->get_key(), "L1", 'down moves to child');
$handle->add_child("L2", "v2");
$handle->first();
$handle->down();
is($handle->depth(), 2, 'depth after second down is 2');
is($handle->get_key(), "L2", 'nested child key');
$handle->up();
is($handle->depth(), 1, 'depth after up is 1');
$handle->top();
is($handle->depth(), 0, 'depth after top is 0');
is($handle->get_key(), "root", 'top returns to root');
};
subtest 'up from root returns undef' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
is($handle->up(), undef, 'up() at root returns undef');
};
subtest 'down with position argument' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->add_child("a", 1);
$handle->add_child("b", 2);
$handle->add_child("c", 3);
$handle->down(1);
is($handle->get_key(), "b", 'down(1) moves to second child');
is($handle->depth(), 1, 'depth is 1');
};
# ============================================================================
# Handle: position
# ============================================================================
subtest 'position get/set' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->add_child("a", 1);
$handle->add_child("b", 2);
$handle->add_child("c", 3);
$handle->position(2);
is($handle->position(), 2, 'position returns set value');
is($handle->get_child_key(), "c", 'position(2) selects third child');
$handle->position(0);
is($handle->position(), 0, 'position(0) works');
is($handle->get_child_key(), "a", 'position(0) selects first child');
};
# ============================================================================
# Handle: select
# ============================================================================
subtest 'select by key' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->add_child("foo", 10);
$handle->add_child("bar", 20);
$handle->add_child("baz", 30);
is($handle->select("bar"), 1, 'select returns true on match');
is($handle->position(), 1, 'position set to found child');
is($handle->select("nonexistent"), undef, 'select returns undef for no match');
};
subtest 'select with custom comparator' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->add_child("ABC", 1);
$handle->add_child("def", 2);
$handle->add_child("GHI", 3);
# Case-insensitive search
my $found = $handle->select("def", sub { return lc(shift) eq lc(shift) });
is($found, 1, 'custom comparator finds match');
is($handle->position(), 1, 'correct position with custom comparator');
};
# ============================================================================
# Handle: add_child with position
# ============================================================================
subtest 'add_child inserts at position' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->add_child("a", 1);
$handle->add_child("c", 3);
# Insert "b" at position 0 (before "a")
$handle->add_child("b", 2, 0);
my @keys = map { $_->key() } $handle->children();
is($keys[0], "b", 'inserted child at position 0');
is($keys[1], "a", 'original first child shifted');
is($keys[2], "c", 'original second child preserved');
};
# ============================================================================
# Handle: add_child_node
# ============================================================================
subtest 'add_child_node with Node object' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
my $node = Tree::MultiNode::Node->new("imported", "value");
$handle->add_child_node($node);
is(scalar($handle->children()), 1, 'one child added');
$handle->first();
$handle->down();
is($handle->get_key(), "imported", 'child_node key correct');
is($handle->get_value(), "value", 'child_node value correct');
};
subtest 'add_child_node with Tree object' => sub {
my $main_tree = Tree::MultiNode->new;
my $main_h = Tree::MultiNode::Handle->new($main_tree);
$main_h->set_key("main");
my $sub_tree = Tree::MultiNode->new;
my $sub_h = Tree::MultiNode::Handle->new($sub_tree);
$sub_h->set_key("subtree_root");
$sub_h->set_value("subval");
$main_h->add_child_node($sub_tree);
is(scalar($main_h->children()), 1, 'subtree added as child');
$main_h->first();
$main_h->down();
is($main_h->get_key(), "subtree_root", 'subtree root key accessible');
};
subtest 'add_child_node rejects invalid argument' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
eval { $handle->add_child_node("not a node") };
like($@, qr/Invalid child argument/, 'dies with non-node argument');
};
# ============================================================================
# Handle: children / child_keys / child_key_positions
# ============================================================================
subtest 'Handle::children returns list' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->add_child("x", 1);
$handle->add_child("y", 2);
my @children = $handle->children();
is(scalar @children, 2, 'children returns correct count');
isa_ok($children[0], 'Tree::MultiNode::Node');
};
subtest 'Handle::child_keys' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->add_child("p", 1);
$handle->add_child("q", 2);
my @keys = $handle->child_keys();
is_deeply(\@keys, ["p", "q"], 'child_keys returns keys in order');
};
subtest 'Handle::child_key_positions' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->add_child("first", 1);
$handle->add_child("second", 2);
my %pos = $handle->child_key_positions();
is($pos{'first'}, 0, 'first at 0');
is($pos{'second'}, 1, 'second at 1');
};
# ============================================================================
# Handle: get_child_key / get_child_value
# ============================================================================
subtest 'get_child_key with explicit position' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->add_child("aa", 11);
$handle->add_child("bb", 22);
$handle->add_child("cc", 33);
is($handle->get_child_key(1), "bb", 'get_child_key(1)');
is($handle->get_child_key(2), "cc", 'get_child_key(2)');
# Position 0 triggers the shift||curr_pos bug (PR #2 will fix)
$handle->first();
is($handle->get_child_key(), "aa", 'get_child_key() uses curr_pos after first()');
};
subtest 'get_child_value with explicit position' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->add_child("aa", 11);
$handle->add_child("bb", 22);
is($handle->get_child_value(1), 22, 'get_child_value(1)');
# Position 0 via curr_pos
$handle->first();
is($handle->get_child_value(), 11, 'get_child_value() uses curr_pos after first()');
};
# ============================================================================
# Handle: kv_pairs
# ============================================================================
subtest 'kv_pairs returns child key-value hash' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->add_child("m", 100);
$handle->add_child("n", 200);
my %pairs = $handle->kv_pairs();
is($pairs{'m'}, 100, 'kv_pairs key m');
is($pairs{'n'}, 200, 'kv_pairs key n');
};
# ============================================================================
# Handle: remove_child
# ============================================================================
subtest 'remove_child removes correct child' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->add_child("a", 1);
$handle->add_child("b", 2);
$handle->add_child("c", 3);
my ($key, $val) = $handle->remove_child(1);
is($key, "b", 'removed child key');
is($val, 2, 'removed child value');
my @keys = map { $_->key() } $handle->children();
is_deeply(\@keys, ["a", "c"], 'remaining children after removal');
};
subtest 'remove_child with invalid position dies' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->add_child("only", 1);
eval { $handle->remove_child(5) };
like($@, qr/invalid position/, 'remove_child with out-of-range position dies');
};
# ============================================================================
# Handle: traverse
# ============================================================================
subtest 'traverse visits all nodes depth-first' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("L", 1);
$handle->add_child("R", 2);
$handle->down(0);
$handle->add_child("LL", 11);
$handle->up();
$handle->down(1);
$handle->add_child("RL", 21);
$handle->top();
my @visited;
$handle->traverse(sub {
my $h = pop;
push @visited, $h->get_key();
});
is(scalar @visited, 5, 'traverse visited 5 nodes');
is($visited[0], "root", 'first visited is root');
};
subtest 'traverse passes extra arguments' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("only");
my @received;
$handle->traverse(sub {
my $h = pop;
push @received, [@_];
}, "arg1", "arg2");
is_deeply($received[0], ["arg1", "arg2"], 'extra args passed to callback');
};
# ============================================================================
# Handle: tree accessor
# ============================================================================
subtest 'Handle::tree returns the tree' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
is($handle->tree(), $tree, 'tree() returns the original tree');
};
# ============================================================================
# Multiple handles on same tree
# ============================================================================
subtest 'multiple handles share same tree' => sub {
my $tree = Tree::MultiNode->new;
my $h1 = Tree::MultiNode::Handle->new($tree);
my $h2 = Tree::MultiNode::Handle->new($tree);
$h1->set_key("shared");
is($h2->get_key(), "shared", 'second handle sees changes from first');
$h1->add_child("child", "val");
is(scalar($h2->children()), 1, 'second handle sees children added by first');
};
# ============================================================================
# Edge cases
# ============================================================================
subtest 'single child tree navigation' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("only_child", "val");
is($handle->first(), 0, 'first on single child');
is($handle->last(), 0, 'last on single child');
is($handle->next(), undef, 'next from only child returns undef');
};
subtest 'deep tree traversal' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
# Build a 5-level deep chain
for my $i (0..4) {
$handle->set_key("level_$i");
$handle->add_child("level_" . ($i+1), $i+1);
$handle->first();
$handle->down();
}
is($handle->depth(), 5, 'reached depth 5');
is($handle->get_key(), "level_5", 'at the deepest node');
# Walk back up
for my $i (reverse 0..4) {
$handle->up();
is($handle->depth(), $i, "back at depth $i");
}
is($handle->get_key(), "level_0", 'back at root');
};
subtest 'get_data returns key-value pair' => sub {
my $tree = Tree::MultiNode->new;
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("thekey");
$handle->set_value("theval");
my ($k, $v) = $handle->get_data();
is($k, "thekey", 'get_data key');
is($v, "theval", 'get_data value');
};
done_testing();
Tree-MultiNode-2.02/t/bugfix-down-no-child.t 000644 000765 000024 00000004313 15164612364 022343 0 ustar 00todd.rinaldo staff 000000 000000 #!perl -T
use strict;
use warnings;
use Test::More;
use Tree::MultiNode;
# Bug fix: down() without current child should return undef, not corrupt handle
subtest 'down() without current child returns undef' => sub {
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("child", 1);
# No child selected — curr_child is undef
is($handle->down(), undef, 'down() returns undef when no child selected');
# Handle should still be valid and pointing at root
is($handle->get_key(), "root", 'handle still points at root after failed down()');
is($handle->depth(), 0, 'depth unchanged after failed down()');
};
subtest 'down() after up() without reselecting child returns undef' => sub {
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("child", 1);
$handle->first();
$handle->down();
is($handle->get_key(), "child", 'navigated down to child');
$handle->up();
is($handle->get_key(), "root", 'navigated back to root');
# curr_child is now undef after up()
is($handle->down(), undef, 'down() returns undef after up() without reselecting');
is($handle->get_key(), "root", 'handle still at root');
};
subtest 'down() after top() without reselecting child returns undef' => sub {
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("child", 1);
$handle->first();
$handle->down();
$handle->top();
is($handle->down(), undef, 'down() returns undef after top() without reselecting');
is($handle->get_key(), "root", 'handle still at root');
is($handle->depth(), 0, 'depth unchanged');
};
subtest 'down(pos) still works correctly' => sub {
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("a", 1);
$handle->add_child("b", 2);
$handle->down(1);
is($handle->get_key(), "b", 'down(1) navigates to child b');
is($handle->depth(), 1, 'depth is 1 after down');
};
done_testing;
Tree-MultiNode-2.02/t/bugfix-weak-parent-refs.t 000644 000765 000024 00000004405 15164612364 023056 0 ustar 00todd.rinaldo staff 000000 000000 #!perl -T
use strict;
use warnings;
use Test::More;
use Tree::MultiNode;
# Weak parent refs: no circular reference leaks
subtest 'parent is a weak reference' => sub {
require Scalar::Util;
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->add_child("a", 1);
$handle->first();
$handle->down();
my $node = $handle->{'curr_node'};
ok(defined $node->parent(), 'child has a parent');
ok(Scalar::Util::isweak($node->{'parent'}), 'parent ref is weak');
};
subtest 'tree is freed when it goes out of scope' => sub {
require Scalar::Util;
my $weak_top;
{
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->add_child("a", 1);
$handle->first();
$handle->down();
$handle->add_child("grandchild", 2);
$weak_top = $tree->{'top'};
Scalar::Util::weaken($weak_top);
ok(defined $weak_top, 'top node alive while tree in scope');
}
is($weak_top, undef, 'top node freed after tree goes out of scope');
};
subtest 'removed subtree is freed without leaking' => sub {
require Scalar::Util;
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->add_child("a", 1);
# Get a weak ref to the child node before removing it
$handle->first();
my $weak_child = $handle->get_child(0);
Scalar::Util::weaken($weak_child);
ok(defined $weak_child, 'child node alive before removal');
$handle->remove_child(0);
is($weak_child, undef, 'removed child node freed (no circular ref leak)');
};
subtest 'no crash during tree destruction (issue #16)' => sub {
# This used to produce "Can't use an undefined value as an ARRAY reference"
# during cleanup when _clearrefs encountered nodes with undef children.
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->add_child("a", 1);
$handle->add_child("b", 2);
$handle->first();
$handle->down();
$handle->add_child("grandchild", 3);
$handle->up();
# Force destruction — should not warn or die
undef $handle;
undef $tree;
pass('tree destruction completed without errors');
};
done_testing;
Tree-MultiNode-2.02/t/bugfix-add-child-node.t 000644 000765 000024 00000004747 15164612364 022450 0 ustar 00todd.rinaldo staff 000000 000000 #!perl -T
use strict;
use warnings;
use Test::More;
use Tree::MultiNode;
# ============================================================================
# Bug fix: add_child_node must not destroy the passed Tree::MultiNode
# ============================================================================
subtest 'add_child_node with Tree preserves the source tree' => sub {
my $tree1 = Tree::MultiNode->new();
my $handle1 = Tree::MultiNode::Handle->new($tree1);
$handle1->set_key("root1");
my $tree2 = Tree::MultiNode->new();
my $handle2 = Tree::MultiNode::Handle->new($tree2);
$handle2->set_key("subtree");
$handle2->set_value("data");
$handle1->add_child_node($tree2);
# tree2 should still be usable
my $handle2b = Tree::MultiNode::Handle->new($tree2);
is($handle2b->get_key(), "subtree", 'source tree still accessible after add_child_node');
is($handle2b->get_value(), "data", 'source tree value intact');
};
subtest 'add_child_node with Node works correctly' => sub {
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
my $node = Tree::MultiNode::Node->new("child_key", "child_val");
$handle->add_child_node($node);
is(scalar($handle->children()), 1, 'one child added');
$handle->first();
is($handle->get_child_key(), "child_key", 'child key correct');
is($handle->get_child_value(), "child_val", 'child value correct');
};
subtest 'add_child_node with position inserts correctly' => sub {
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("a", 1);
$handle->add_child("b", 2);
my $node = Tree::MultiNode::Node->new("inserted", 99);
$handle->add_child_node($node, 0);
is(scalar($handle->children()), 3, 'three children after insert');
$handle->first();
is($handle->get_child_key(), "inserted", 'inserted node is at position 0');
$handle->next();
is($handle->get_child_key(), "a", 'original first child shifted to position 1');
};
subtest 'add_child_node rejects invalid child types' => sub {
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
eval { $handle->add_child_node("not a node") };
like($@, qr/Invalid child argument/, 'rejects string argument');
eval { $handle->add_child_node({}) };
like($@, qr/Invalid child argument/, 'rejects hashref argument');
};
done_testing;
Tree-MultiNode-2.02/t/01-multinode.t 000644 000765 000024 00000010222 15160067036 020625 0 ustar 00todd.rinaldo staff 000000 000000 #!perl -T
use Test::More tests => 85;
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("**** test remove_child at position 0");
{
my $t2 = Tree::MultiNode->new;
my $h2 = Tree::MultiNode::Handle->new($t2);
$h2->add_child("x", 10);
$h2->add_child("y", 20);
$h2->add_child("z", 30);
my @rv = $h2->remove_child(0);
is($rv[0], "x", "remove_child(0) returns correct key");
is($rv[1], 10, "remove_child(0) returns correct value");
my %p2 = $h2->kv_pairs();
ok(!defined $p2{'x'}, "child x removed");
ok( defined $p2{'y'}, "child y still present");
ok( defined $p2{'z'}, "child z still present");
my @keys = $h2->child_keys();
is(scalar @keys, 2, "child count is 2 after remove_child(0)");
}
pass("**** test remove_child updates children persistently");
{
my $t3 = Tree::MultiNode->new;
my $h3 = Tree::MultiNode::Handle->new($t3);
$h3->add_child("p", 1);
$h3->add_child("q", 2);
$h3->remove_child(0);
my @keys = $h3->child_keys();
is(scalar @keys, 1, "children persist after remove_child");
}
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");
pass("**** test Node constructor with falsy keys");
{
my $node_zero = Tree::MultiNode::Node->new(0, "zero_val");
is($node_zero->key(), 0, "Node->new(0, ...) preserves key 0");
is($node_zero->value(), "zero_val", "Node->new(0, ...) preserves value");
my $node_empty = Tree::MultiNode::Node->new("", "empty_val");
is($node_empty->key(), "", "Node->new('', ...) preserves empty string key");
is($node_empty->value(), "empty_val", "Node->new('', ...) preserves value");
}
#done_testing();
Tree-MultiNode-2.02/t/bugfix-negative-position.t 000644 000765 000024 00000002630 15164612364 023345 0 ustar 00todd.rinaldo staff 000000 000000 #!perl -T
use strict;
use warnings;
use Test::More;
use Tree::MultiNode;
# ============================================================================
# Bug fix: negative position validation in add_child, add_child_node, position
# ============================================================================
subtest 'add_child rejects negative position' => sub {
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("a", 1);
$handle->add_child("b", 2);
eval { $handle->add_child("bad", "val", -1) };
like($@, qr/invalid/i, 'add_child rejects negative position');
};
subtest 'add_child_node rejects negative position' => sub {
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("a", 1);
my $node = Tree::MultiNode::Node->new("bad", "val");
eval { $handle->add_child_node($node, -1) };
like($@, qr/invalid/i, 'add_child_node rejects negative position');
};
subtest 'position() rejects negative values' => sub {
my $tree = Tree::MultiNode->new();
my $handle = Tree::MultiNode::Handle->new($tree);
$handle->set_key("root");
$handle->add_child("a", 1);
$handle->add_child("b", 2);
eval { $handle->position(-1) };
like($@, qr/invalid/i, 'position() rejects -1');
};
done_testing;
Tree-MultiNode-2.02/t/bugfix-node-key-falsy.t 000644 000765 000024 00000000632 15164612364 022530 0 ustar 00todd.rinaldo staff 000000 000000 #!perl -T
use strict;
use warnings;
use Test::More;
use Tree::MultiNode;
# Verify Node::key() still works with falsy values (regression check)
subtest 'Node::key() handles falsy values' => sub {
my $node = Tree::MultiNode::Node->new();
$node->key(0);
is($node->key(), 0, 'key can be set to 0');
$node->key("");
is($node->key(), "", 'key can be set to empty string');
};
done_testing;