Forest-0.10/000755 000767 000120 00000000000 12254320621 013320 5ustar00stevanadmin000000 000000 Forest-0.10/Changes000644 000767 000767 00000005645 12254320106 015054 0ustar00stevanstevan000000 000000 Revision history for Perl extension Forest 0.10 Wed. Dec. 8th, 2013 - remove MooseX::AttributeHelpers dependency (doy) 0.09 Mon. Sep. 27, 2010 - silence warnings on new Moose (doy) 0.08 Wed. Jan. 13, 2010 *** MAJOR REFACTORINGS *** (by nothingmuch) + Forest::Tree::Pure + Forest::Tree::Constructor + Forest::Tree::Builder + Forest::Tree::Builder::Callback + Forest::Tree::Builder::SimpleTextFile - added these packages as well as tests * Forest::Tree - this is now a subclass of Forest::Tree::Pure - many other changes all over the place as well as best we can tell this is still 100% back-compat but if you experience anything to the contrary please let us know ASAP. Thanks. 0.07 Sat. July 18, 2009 - Fix spelling of weak_ref in some attrs (cory watson) * Forest::Tree::Writer - no longer a weak-ref on the tree because that is probably not what we actually want. 0.06 Fri. Feb. 27, 2009 - whoops, tons of .git stuff in that last release - updated MANIFEST.SKIP so don't get all that git stuff 0.05 Fri. Feb. 27, 2009 - fixed all the test plans and updated copyright 0.04 Sun. Sept. 7, 2008 * Forest::Tree::Writer::SimpleHTML - removed Sub::Current dependency because it cannot be compiled on Win32 with 5.8.* (thanks to Nilson Santos Figueiredo Junior) 0.03 Sun. Aug. 10, 2008 * Forest::Tree - fixing bug where children were not getting the parent sorted correctly - added several tests for this 0.02 Sat. July 12, 2008 ~ converted from Module::Build to Module::Install -- removed Forest::Tree::Service::* this will be moved to another distro soon. * Forest::Tree - added size and height attributes (groditi) * Forest::Tree::Writer Forest::Tree::Writer::SimpleASCII Forest::Tree::Writer::SimpleHTML - added node_formatter support - added tests for this * Forest::Tree::Writer::ASCIIWithBranches - added this module for drawing ASCII trees with nice little branches and such. - added tests for this * Forest::Tree::Roles::CanCreateSubTree - refactored out some common functionality into roles * Forest::Tree::Loader - added this generic role for loading of trees. * Forest::Tree::Loader::SimpleUIDLoader - added this module as a way to load a tree from a simple ArrayOfHash tables - added tests for this * Forest::Tree::Roles::LoadWithMetaData - simple role to work with loaders and add the metadata in as the tree is being created - added tests for this * Forest::Tree::Reader - this now also ->does(Forest::Tree::Loader) so that you can be more general about how your stuff gets loaded. - added tests for this 0.01 Wed. Feb. 13, 2008 - filling a needForest-0.10/inc/000755 000767 000120 00000000000 12254320621 014071 5ustar00stevanadmin000000 000000 Forest-0.10/lib/000755 000767 000120 00000000000 12254320621 014066 5ustar00stevanadmin000000 000000 Forest-0.10/Makefile.PL000644 000767 000120 00000000713 12254317640 015302 0ustar00stevanadmin000000 000000 use strict; use warnings; use inc::Module::Install; name 'Forest'; all_from 'lib/Forest.pm'; license 'perl'; # prereqs requires 'Moose' => '2.0000'; requires 'MooseX::Clone' => '0.05'; requires 'Scalar::Util' => '1.17'; requires 'List::Util' => '1.17'; # things the tests need build_requires 'Test::More'; build_requires 'Test::Exception'; build_requires 'Path::Class'; tests('t/*.t'); WriteAll(); Forest-0.10/MANIFEST000644 000767 000120 00000002611 12254320606 014454 0ustar00stevanadmin000000 000000 Changes inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Forest.pm lib/Forest/Tree.pm lib/Forest/Tree/Builder.pm lib/Forest/Tree/Builder/Callback.pm lib/Forest/Tree/Builder/SimpleTextFile.pm lib/Forest/Tree/Constructor.pm lib/Forest/Tree/Indexer.pm lib/Forest/Tree/Indexer/SimpleUIDIndexer.pm lib/Forest/Tree/Loader.pm lib/Forest/Tree/Loader/SimpleUIDLoader.pm lib/Forest/Tree/Pure.pm lib/Forest/Tree/Reader.pm lib/Forest/Tree/Reader/SimpleTextFile.pm lib/Forest/Tree/Roles/HasNodeFormatter.pm lib/Forest/Tree/Roles/JSONable.pm lib/Forest/Tree/Roles/LoadWithMetaData.pm lib/Forest/Tree/Roles/MetaData.pm lib/Forest/Tree/Writer.pm lib/Forest/Tree/Writer/ASCIIWithBranches.pm lib/Forest/Tree/Writer/SimpleASCII.pm lib/Forest/Tree/Writer/SimpleHTML.pm Makefile.PL MANIFEST This list of files META.yml MYMETA.json MYMETA.yml README t/000_load.t t/010_Tree.t t/011_Tree_MetaData.t t/012_Tree_errors.t t/013_Tree_build_with_constructor.t t/014_Pure.t t/020_Tree_Reader.t t/021_Tree_Reader_using_load.t t/030_Tree_Writer.t t/031_Tree_Writer_to_disk.t t/032_Tree_Writer_complex_ASCII.t t/033_Tree_Writer_incremental_build.t t/040_Tree_Indexer.t t/041_Tree_Indexer_w_custom_reader.t t/060_Tree_Loader.t t/061_Tree_Loader_with_metadata.t t/pod.t Forest-0.10/META.yml000644 000767 000120 00000001232 12254320603 014567 0ustar00stevanadmin000000 000000 --- abstract: 'A collection of n-ary tree related modules' author: - 'Stevan Little ' build_requires: ExtUtils::MakeMaker: 6.36 Path::Class: 0 Test::Exception: 0 Test::More: 0 configure_requires: ExtUtils::MakeMaker: 6.36 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.06' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Forest no_index: directory: - inc - t requires: List::Util: 1.17 Moose: 2.0000 MooseX::Clone: 0.05 Scalar::Util: 1.17 resources: license: http://dev.perl.org/licenses/ version: 0.10 Forest-0.10/MYMETA.json000644 000767 000120 00000002266 12254320603 015215 0ustar00stevanadmin000000 000000 { "abstract" : "A collection of n-ary tree related modules", "author" : [ "Stevan Little " ], "dynamic_config" : 0, "generated_by" : "Module::Install version 1.06, CPAN::Meta::Converter version 2.132830", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Forest", "no_index" : { "directory" : [ "inc", "t" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "6.36", "Path::Class" : "0", "Test::Exception" : "0", "Test::More" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.36" } }, "runtime" : { "requires" : { "List::Util" : "1.17", "Moose" : "2.0000", "MooseX::Clone" : "0.05", "Scalar::Util" : "1.17" } } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.10" } Forest-0.10/MYMETA.yml000644 000767 000120 00000001250 12254320603 015035 0ustar00stevanadmin000000 000000 --- abstract: 'A collection of n-ary tree related modules' author: - 'Stevan Little ' build_requires: ExtUtils::MakeMaker: 6.36 Path::Class: 0 Test::Exception: 0 Test::More: 0 configure_requires: ExtUtils::MakeMaker: 6.36 dynamic_config: 0 generated_by: 'Module::Install version 1.06, CPAN::Meta::Converter version 2.132830' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Forest no_index: directory: - inc - t requires: List::Util: 1.17 Moose: 2.0000 MooseX::Clone: 0.05 Scalar::Util: 1.17 resources: license: http://dev.perl.org/licenses/ version: 0.10 Forest-0.10/README000644 000767 000120 00000001123 12254320033 014172 0ustar00stevanadmin000000 000000 Forest version 0.10 ================================================= See the individual module documentation for more information INSTALLATION To install this module type the following: perl Makefile.PL make make test make install DEPENDENCIES This module requires these other modules and libraries: Moose MooseX::Clone List::Util Scalar::Util COPYRIGHT AND LICENCE Copyright (C) 2008-2014 Infinity Interactive, Inc. http://www.iinteractive.com This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Forest-0.10/t/000755 000767 000120 00000000000 12254320621 013563 5ustar00stevanadmin000000 000000 Forest-0.10/t/000_load.t000644 000767 000767 00000001270 11151776700 015507 0ustar00stevanstevan000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 15; use_ok('Forest'); use_ok('Forest::Tree'); use_ok('Forest::Tree::Reader'); use_ok('Forest::Tree::Reader::SimpleTextFile'); use_ok('Forest::Tree::Writer'); use_ok('Forest::Tree::Writer::SimpleASCII'); use_ok('Forest::Tree::Writer::ASCIIWithBranches'); use_ok('Forest::Tree::Writer::SimpleHTML'); use_ok('Forest::Tree::Indexer'); use_ok('Forest::Tree::Indexer::SimpleUIDIndexer'); use_ok('Forest::Tree::Loader'); use_ok('Forest::Tree::Loader::SimpleUIDLoader'); use_ok('Forest::Tree::Roles::JSONable'); use_ok('Forest::Tree::Roles::HasNodeFormatter'); use_ok('Forest::Tree::Roles::MetaData'); Forest-0.10/t/010_Tree.t000644 000767 000767 00000013113 11323404233 015455 0ustar00stevanstevan000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 89; use Test::Exception; BEGIN { use_ok('Forest::Tree'); }; my $t = Forest::Tree->new(); isa_ok($t, 'Forest::Tree'); ok($t->is_root, '... this is the tree root'); ok($t->is_leaf, '... this is the leaf'); ok(!defined $t->parent, '... no parent'); ok(!$t->has_parent, '... no parent'); ok(!defined $t->node, '... no node value'); is_deeply($t->children, [], '... no children'); is($t->depth, -1, '... the root has a depth of -1'); is($t->height, 0, '... the root has a height of 0'); is($t->size, 1, '... the root has a size of 1'); my $child_1 = Forest::Tree->new(node => '1.0'); isa_ok($child_1, 'Forest::Tree'); ok(!defined $child_1->parent, '... no parent'); ok(!$child_1->has_parent, '... no parent'); ok($child_1->is_leaf, '... this is a leaf'); ok($child_1->is_root, '... this is a root'); is($child_1->node, '1.0', '... got the right node value'); is($child_1->depth, -1, '... the child has a depth of -1'); is_deeply($child_1->children, [], '... no children'); $t->add_child($child_1); ok(!$t->is_leaf, '... this is no longer leaf'); is_deeply($t->children, [ $child_1 ], '... 1 child'); is($t->depth, -1, '... the root still has a depth of -1'); is($t->height, 1, '... the root now has a height of 1'); is($t->size, 2, '... the root now has a size of 2'); is($t->get_child_at(0), $child_1, '... got the right child'); ok(!$child_1->is_root, '... this is no longer a root'); ok($child_1->is_leaf, '... but this is still a leaf'); ok(defined $child_1->parent, '... has parent now'); ok($child_1->has_parent, '... has parent now'); isa_ok($child_1->parent, 'Forest::Tree'); is($child_1->parent, $t, '... its parent is tree'); is($child_1->depth, 0, '... the child now has a depth of 0'); is_deeply($child_1->siblings, [], '... There are no siblings'); my $child_1_1 = Forest::Tree->new(node => '1.1'); isa_ok($child_1_1, 'Forest::Tree'); ok(!defined $child_1_1->parent, '... no parent'); ok(!$child_1_1->has_parent, '... no parent'); ok($child_1_1->is_leaf, '... this is a leaf'); ok($child_1_1->is_root, '... this is a root'); is($child_1_1->node, '1.1', '... got the right node value'); is($child_1_1->depth, -1, '... the child has a depth of -1'); is_deeply($child_1_1->children, [], '... no children'); $t->get_child_at(0)->add_child($child_1_1); is_deeply($child_1->children, [ $child_1_1 ], '... one child'); ok(!$child_1->is_leaf, '... this is no longer a leaf'); is($child_1->depth, 0, '... the child still has a depth of 0'); ok(!$child_1_1->is_root, '... this is no longer a root'); ok($child_1_1->is_leaf, '... but this is still a leaf'); ok(defined $child_1_1->parent, '... has parent now'); ok($child_1_1->has_parent, '... has parent now'); isa_ok($child_1_1->parent, 'Forest::Tree'); is($child_1_1->parent, $child_1, '... its parent is tree'); is($child_1_1->depth, 1, '... the child now has a depth of 1'); is($t->height, 2, '... the root now has a height of 2'); is($t->size, 3, '... the root now has a size of 3'); my $child_2 = Forest::Tree->new(node => '2.0'); isa_ok($child_2, 'Forest::Tree'); my $child_3 = Forest::Tree->new(node => '3.0'); isa_ok($child_3, 'Forest::Tree'); my $child_4 = Forest::Tree->new(node => '4.0'); isa_ok($child_4, 'Forest::Tree'); $child_1->add_sibling($child_4); is_deeply($child_1->siblings, [ $child_4 ], '... There are no siblings'); is_deeply($t->children, [ $child_1, $child_4 ], '... 2 children'); ok(!$child_4->is_root, '... this is no longer a root'); ok($child_4->is_leaf, '... but this is still a leaf'); is($child_4->parent, $t, '... its parent is tree'); is($child_4->depth, 0, '... the child now has a depth of 1'); $t->insert_child_at(1, $child_2); is_deeply($t->children, [ $child_1, $child_2, $child_4 ], '... 3 children'); ok(!$child_2->is_root, '... this is no longer a root'); ok($child_2->is_leaf, '... but this is still a leaf'); is($child_2->parent, $t, '... its parent is tree'); is($child_2->depth, 0, '... the child now has a depth of 1'); $child_2->insert_sibling_at(2, $child_3); is_deeply($t->children, [ $child_1, $child_2, $child_3, $child_4 ], '... 4 children'); ok(!$child_3->is_root, '... this is no longer a root'); ok($child_3->is_leaf, '... but this is still a leaf'); is($child_3->parent, $t, '... its parent is tree'); is($child_3->depth, 0, '... the child now has a depth of 1'); is($t->height, 2, '... the root now has a height of 2'); is($t->size, 6, '... the root now has a size of 6'); ok($t->remove_child_at(0), '... removing child 1'); is($t->height, 1, '... the root now has a height of 1'); is($t->size, 4, '... the root now has a size of 4'); # clear them ... $t->clear_size; $t->clear_height; # regenerate ... ok($t->remove_child_at(0), '... removing child 1'); is($t->height, 1, '... the root now has a height of 1'); is($t->size, 3, '... the root now has a size of 3'); my $child_5 = Forest::Tree->new(node => '5.0'); my $child_6 = Forest::Tree->new(node => '6.0'); my $child_7 = Forest::Tree->new(node => '7.0'); $t->transform( [ 1 ], insert_child_at => 0, $child_5 ); is($t->height, 2, '... the root now has a height of 1'); is($t->size, 4, '... the root now has a size of 3'); is_deeply( $t->locate(1, 0), $child_5, "locate new child" ); $t->transform( [ 1, 0 ], add_child => $child_6 ); is($t->height, 3, '... the root now has a height of 1'); is($t->size, 5, '... the root now has a size of 3'); is( $t->locate(1, 0, 0)->node, '6.0', "correct node" ); $t->transform( [ 1, 0 ], replace => $child_7 ); is($t->height, 2, '... the root now has a height of 1'); is($t->size, 4, '... the root now has a size of 3'); is( $t->locate(1, 0)->node, "7.0", "correct node" ); Forest-0.10/t/011_Tree_MetaData.t000644 000767 000767 00000011520 11323404233 017216 0ustar00stevanstevan000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 34; BEGIN { use_ok('Forest::Tree'); use_ok('Forest::Tree::Reader::SimpleTextFile'); use_ok('Forest::Tree::Indexer'); use_ok('Forest::Tree::Indexer::SimpleUIDIndexer'); use_ok('Forest::Tree::Roles::MetaData'); }; { { package My::Tree; use Moose; extends 'Forest::Tree'; with 'Forest::Tree::Roles::MetaData'; __PACKAGE__->meta->make_immutable(); package My::Tree::Reader; use Moose; extends 'Forest::Tree::Reader::SimpleTextFile'; has '+tree' => ( default => sub { My::Tree->new( node => '0.0|DEFAULT', metadata => { number => '0.0', name => 'DEFAULT' } ) } ); sub build_parser { return sub { my ($self, $line) = @_; my ($indent, $node) = ($line =~ /^(\s*)(.*)$/); my $depth = ((length $indent) / $self->tab_width); my ($number, $name) = (split /\|/ => $node); my $tree = My::Tree->new( node => $node, metadata => { (($number) ? (number => $number) : ()), (($name) ? (name => $name ) : ()), } ); return ($depth, $tree); } } __PACKAGE__->meta->make_immutable(); } ok(My::Tree->isa('Forest::Tree'), '... My::Tree isa Forest::Tree'); ok(My::Tree->isa('Forest::Tree::Pure'), '... My::Tree isa Forest::Tree::Pure'); ok(My::Tree->does('Forest::Tree::Roles::MetaData'), '... My::Tree does Forest::Tree::Roles::MetaData'); my $reader = My::Tree::Reader->new; isa_ok($reader, 'My::Tree::Reader'); isa_ok($reader, 'Forest::Tree::Reader::SimpleTextFile'); $reader->read(\*DATA); my $tree = $reader->tree; isa_ok($tree, 'My::Tree'); isa_ok($tree, 'Forest::Tree'); ok($tree->does('Forest::Tree::Roles::MetaData'), '... our tree does Forest::Tree::Roles::MetaData'); is($tree->node, '0.0|DEFAULT', '... got the right root node'); is_deeply($tree->metadata, { number => '0.0', name => 'DEFAULT' }, '... got the right metadata hash'); is($tree->fetch_metadata_for('number'), '0.0', '... got the right root node metadata'); is($tree->fetch_metadata_for('name'), 'DEFAULT', '... got the right root node metadata'); is($tree->get_child_at(0)->node, '1.0', '... got the right root node'); is_deeply($tree->get_child_at(0)->metadata, { number => '1.0' }, '... got the right metadata hash'); is($tree->get_child_at(0)->get_metadata_for('number'), '1.0', '... got the right metadata hash'); is($tree->get_child_at(0)->fetch_metadata_for('number'), '1.0', '... got the right root node metadata'); is($tree->get_child_at(0)->fetch_metadata_for('name'), 'DEFAULT', '... got the right root node metadata'); is($tree->get_child_at(0)->get_child_at(0)->node, '1.1|One-Point-One', '... got the right root node'); is($tree->get_child_at(0)->get_child_at(0)->fetch_metadata_for('number'), '1.1', '... got the right root node metadata'); is($tree->get_child_at(0)->get_child_at(0)->fetch_metadata_for('name'), 'One-Point-One', '... got the right root node metadata'); is($tree->get_child_at(0)->get_child_at(1)->node, '1.2|One-Point-Two', '... got the right root node'); is($tree->get_child_at(0)->get_child_at(1)->fetch_metadata_for('number'), '1.2', '... got the right root node metadata'); is($tree->get_child_at(0)->get_child_at(1)->fetch_metadata_for('name'), 'One-Point-Two', '... got the right root node metadata'); is($tree->get_child_at(0)->get_child_at(1)->get_child_at(0)->node, '1.2.1', '... got the right root node'); is($tree->get_child_at(0)->get_child_at(1)->get_child_at(0)->fetch_metadata_for('number'), '1.2.1', '... got the right root node metadata'); is($tree->get_child_at(0)->get_child_at(1)->get_child_at(0)->fetch_metadata_for('name'), 'One-Point-Two', '... got the right root node metadata'); is($tree->get_child_at(0)->get_child_at(1)->get_child_at(1)->node, '|One-Point-Two-Point-Two', '... got the right root node'); is($tree->get_child_at(0)->get_child_at(1)->get_child_at(1)->fetch_metadata_for('number'), '1.2', '... got the right root node metadata'); is($tree->get_child_at(0)->get_child_at(1)->get_child_at(1)->fetch_metadata_for('name'), 'One-Point-Two-Point-Two', '... got the right root node metadata'); } __DATA__ 1.0 1.1|One-Point-One 1.2|One-Point-Two 1.2.1 |One-Point-Two-Point-Two Forest-0.10/t/012_Tree_errors.t000644 000767 000767 00000002220 11151777032 017061 0ustar00stevanstevan000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 10; use Test::Exception; BEGIN { use_ok('Forest::Tree'); }; my $t = Forest::Tree->new(); isa_ok($t, 'Forest::Tree'); # test some errors throws_ok { $t->add_child(undef); } qr/Child parameter must be a Forest\:\:Tree not/, '... throws exception'; throws_ok { $t->add_child([]); } qr/Child parameter must be a Forest\:\:Tree not/, '... throws exception'; throws_ok { $t->add_child({}); } qr/Child parameter must be a Forest\:\:Tree not/, '... throws exception'; throws_ok { $t->add_child(bless {} => 'Foo'); } qr/Child parameter must be a Forest\:\:Tree not/, '... throws exception'; throws_ok { $t->insert_child_at(undef); } qr/Child parameter must be a Forest\:\:Tree not/, '... throws exception'; throws_ok { $t->insert_child_at([]); } qr/Child parameter must be a Forest\:\:Tree not/, '... throws exception'; throws_ok { $t->insert_child_at({}); } qr/Child parameter must be a Forest\:\:Tree not/, '... throws exception'; throws_ok { $t->insert_child_at(bless {} => 'Foo'); } qr/Child parameter must be a Forest\:\:Tree not/, '... throws exception'; Forest-0.10/t/013_Tree_build_with_constructor.t000644 000767 000767 00000002426 11151777046 022362 0ustar00stevanstevan000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 17; use Test::Exception; BEGIN { use_ok('Forest::Tree'); } my $root = Forest::Tree->new( node => 'root', children => [ Forest::Tree->new( node => '1.0', children => [ Forest::Tree->new(node => '1.1'), Forest::Tree->new(node => '1.2'), ] ), Forest::Tree->new( node => '2.0', children => [ Forest::Tree->new( node => '2.1', children => [ Forest::Tree->new(node => '2.1.1'), Forest::Tree->new(node => '2.1.2'), ] ), ] ) ] ); isa_ok($root, 'Forest::Tree'); my @output; $root->traverse(sub { my $t = shift; isa_ok($t, 'Forest::Tree'); ok($t->has_parent, '... got a parent node'); push @output => [ $t->depth, $t->node, $t->parent->node ] }); is_deeply( \@output, [ [0,'1.0','root'], [1,'1.1','1.0'], [1,'1.2','1.0'], [0,'2.0','root'], [1,'2.1','2.0'], [2,'2.1.1','2.1'], [2,'2.1.2','2.1'], ], '... the tree was properly initialized' ); Forest-0.10/t/014_Pure.t000644 000767 000767 00000007634 11323404233 015510 0ustar00stevanstevan000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 52; use Test::Exception; BEGIN { use_ok('Forest::Tree::Pure'); }; my $t = Forest::Tree::Pure->new(); isa_ok($t, 'Forest::Tree::Pure'); ok($t->is_leaf, '... this is the leaf'); ok(!defined $t->node, '... no node value'); is_deeply($t->children, [], '... no children'); is($t->height, 0, '... the root has a height of 0'); is($t->size, 1, '... the root has a size of 1'); my $child_1 = Forest::Tree::Pure->new(node => '1.0'); isa_ok($child_1, 'Forest::Tree::Pure'); ok($child_1->is_leaf, '... this is a leaf'); is($child_1->node, '1.0', '... got the right node value'); is_deeply($child_1->children, [], '... no children'); my $clone = $t->add_child($child_1); ok($t->is_leaf, '... original unmodified'); ok(!defined $t->node, '... no node value'); is_deeply($t->children, [], '... no children'); is($t->height, 0, '... the root has a height of 0'); is($t->size, 1, '... the root has a size of 1'); ok(!$clone->is_leaf, '... this is no longer leaf'); is_deeply($clone->children, [ $child_1 ], '... 1 child'); is($clone->height, 1, '... the root now has a height of 1'); is($clone->size, 2, '... the root now has a size of 2'); is($clone->get_child_at(0), $child_1, '... got the right child'); ok($child_1->is_leaf, '... child is still a leaf'); my $child_1_1 = Forest::Tree::Pure->new(node => '1.1'); isa_ok($child_1_1, 'Forest::Tree::Pure'); ok($child_1_1->is_leaf, '... this is a leaf'); is($child_1_1->node, '1.1', '... got the right node value'); is_deeply($child_1_1->children, [], '... no children'); #### XXX $t is overwritten here ##### $t = $clone->set_child_at( 0 => $clone->get_child_at(0)->add_child($child_1_1) ); $child_1 = $t->get_child_at(0); is_deeply($child_1->children, [ $child_1_1 ], '... one child'); ok(!$child_1->is_leaf, '... this is no longer a leaf'); ok($child_1_1->is_leaf, '... but this is still a leaf'); is($t->height, 2, '... the root now has a height of 2'); is($t->size, 3, '... the root now has a size of 3'); my $child_2 = Forest::Tree::Pure->new(node => '2.0'); isa_ok($child_2, 'Forest::Tree::Pure'); my $child_3 = Forest::Tree::Pure->new(node => '3.0'); isa_ok($child_3, 'Forest::Tree::Pure'); my $child_4 = Forest::Tree::Pure->new(node => '4.0'); isa_ok($child_4, 'Forest::Tree::Pure'); $t = $t->add_child($child_4); is_deeply($t->children, [ $child_1, $child_4 ], '... 2 children'); $t = $t->insert_child_at(1, $child_2); is_deeply($t->children, [ $child_1, $child_2, $child_4 ], '... 3 children'); $t = $t->insert_child_at(2, $child_3); is_deeply($t->children, [ $child_1, $child_2, $child_3, $child_4 ], '... 4 children'); is($t->height, 2, '... the root now has a height of 2'); is($t->size, 6, '... the root now has a size of 6'); $t = $t->remove_child_at(0); is($t->height, 1, '... the root now has a height of 1'); is($t->size, 4, '... the root now has a size of 4'); # clear them ... $t->clear_size; $t->clear_height; # regenerate ... $t = $t->remove_child_at(0); is($t->height, 1, '... the root now has a height of 1'); is($t->size, 3, '... the root now has a size of 3'); my $child_5 = Forest::Tree::Pure->new(node => '5.0'); my $child_6 = Forest::Tree::Pure->new(node => '6.0'); my $child_7 = Forest::Tree::Pure->new(node => '7.0'); $t = $t->transform( [ 1 ], insert_child_at => 0, $child_5 ); is($t->height, 2, '... the root now has a height of 1'); is($t->size, 4, '... the root now has a size of 3'); is_deeply( $t->locate(1, 0), $child_5, "locate new child" ); $t = $t->transform( [ 1, 0 ], add_child => $child_6 ); is($t->height, 3, '... the root now has a height of 1'); is($t->size, 5, '... the root now has a size of 3'); is_deeply( $t->locate(1, 0, 0), $child_6, "locate new child" ); $t = $t->transform( [ 1, 0 ], replace => $child_7 ); is($t->height, 2, '... the root now has a height of 1'); is($t->size, 4, '... the root now has a size of 3'); is( $t->locate(1, 0)->node, "7.0", "correct node" ); Forest-0.10/t/020_Tree_Reader.t000644 000767 000767 00000003623 11151777064 016763 0ustar00stevanstevan000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 23; use Test::Exception; BEGIN { use_ok('Forest::Tree'); use_ok('Forest::Tree::Reader'); use_ok('Forest::Tree::Reader::SimpleTextFile'); }; { my $reader = Forest::Tree::Reader::SimpleTextFile->new(); isa_ok($reader, 'Forest::Tree::Reader::SimpleTextFile'); ok($reader->does('Forest::Tree::Reader'), '... loader does Forest::Tree::Reader'); my $tree = $reader->tree; isa_ok($tree, 'Forest::Tree'); ok($tree->is_root, '... tree is a root'); ok($tree->is_leaf, '... tree is a leaf'); is($tree->child_count, 0, '... tree has no children'); lives_ok { $reader->read(\*DATA); } '... loaded the tree'; ok($tree->is_root, '... tree is a root'); ok(!$tree->is_leaf, '... tree is not a leaf'); is($tree->child_count, 4, '... tree has 4 children'); is($tree->get_child_at(0)->node, '1.0', '... got the right node'); is($tree->get_child_at(0)->get_child_at(0)->node, '1.1', '... got the right node'); is($tree->get_child_at(0)->get_child_at(1)->node, '1.2', '... got the right node'); is($tree->get_child_at(0)->get_child_at(1)->get_child_at(0)->node, '1.2.1', '... got the right node'); is($tree->get_child_at(1)->node, '2.0', '... got the right node'); is($tree->get_child_at(1)->get_child_at(0)->node, '2.1', '... got the right node'); is($tree->get_child_at(2)->node, '3.0', '... got the right node'); is($tree->get_child_at(3)->node, '4.0', '... got the right node'); is($tree->get_child_at(3)->get_child_at(0)->node, '4.1', '... got the right node'); is($tree->get_child_at(3)->get_child_at(0)->get_child_at(0)->node, '4.1.1', '... got the right node'); } __DATA__ 1.0 1.1 1.2 1.2.1 2.0 2.1 3.0 4.0 4.1 4.1.1 Forest-0.10/t/021_Tree_Reader_using_load.t000644 000767 000767 00000003623 11151777103 021162 0ustar00stevanstevan000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 23; use Test::Exception; BEGIN { use_ok('Forest::Tree'); use_ok('Forest::Tree::Reader'); use_ok('Forest::Tree::Reader::SimpleTextFile'); }; { my $reader = Forest::Tree::Reader::SimpleTextFile->new(); isa_ok($reader, 'Forest::Tree::Reader::SimpleTextFile'); ok($reader->does('Forest::Tree::Reader'), '... loader does Forest::Tree::Reader'); my $tree = $reader->tree; isa_ok($tree, 'Forest::Tree'); ok($tree->is_root, '... tree is a root'); ok($tree->is_leaf, '... tree is a leaf'); is($tree->child_count, 0, '... tree has no children'); lives_ok { $reader->load(\*DATA); } '... loaded the tree'; ok($tree->is_root, '... tree is a root'); ok(!$tree->is_leaf, '... tree is not a leaf'); is($tree->child_count, 4, '... tree has 4 children'); is($tree->get_child_at(0)->node, '1.0', '... got the right node'); is($tree->get_child_at(0)->get_child_at(0)->node, '1.1', '... got the right node'); is($tree->get_child_at(0)->get_child_at(1)->node, '1.2', '... got the right node'); is($tree->get_child_at(0)->get_child_at(1)->get_child_at(0)->node, '1.2.1', '... got the right node'); is($tree->get_child_at(1)->node, '2.0', '... got the right node'); is($tree->get_child_at(1)->get_child_at(0)->node, '2.1', '... got the right node'); is($tree->get_child_at(2)->node, '3.0', '... got the right node'); is($tree->get_child_at(3)->node, '4.0', '... got the right node'); is($tree->get_child_at(3)->get_child_at(0)->node, '4.1', '... got the right node'); is($tree->get_child_at(3)->get_child_at(0)->get_child_at(0)->node, '4.1.1', '... got the right node'); } __DATA__ 1.0 1.1 1.2 1.2.1 2.0 2.1 3.0 4.0 4.1 4.1.1 Forest-0.10/t/030_Tree_Writer.t000644 000767 000767 00000005442 11323404233 017021 0ustar00stevanstevan000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 29; BEGIN { use_ok('Forest::Tree'); use_ok('Forest::Tree::Reader::SimpleTextFile'); use_ok('Forest::Tree::Writer'); use_ok('Forest::Tree::Writer::SimpleASCII'); use_ok('Forest::Tree::Writer::SimpleHTML'); }; my $reader = Forest::Tree::Reader::SimpleTextFile->new; $reader->read(\*DATA); sub to_pure { my $tree = shift; Forest::Tree::Pure->new( ( $tree->has_node ? ( node => $tree->node ) : () ), children => [ map { to_pure($_) } @{ $tree->children } ], ); } my $tree = $reader->tree; my $pure = to_pure($tree); foreach my $tree ( $tree, $pure ) { my $w = Forest::Tree::Writer::SimpleASCII->new(tree => $tree); isa_ok($w, 'Forest::Tree::Writer::SimpleASCII'); isa_ok($w->tree, 'Forest::Tree::Pure'); is($w->as_string, q{1.0 1.1 1.2 1.2.1 2.0 2.1 3.0 4.0 4.1 4.1.1 }, '.... got the right output'); } foreach my $tree ( $tree, $pure ) { my $w = Forest::Tree::Writer::SimpleASCII->new( tree => $tree, node_formatter => sub { '[' . (shift)->node . ']' } ); isa_ok($w, 'Forest::Tree::Writer::SimpleASCII'); isa_ok($w->tree, 'Forest::Tree::Pure'); is($w->as_string, q{[1.0] [1.1] [1.2] [1.2.1] [2.0] [2.1] [3.0] [4.0] [4.1] [4.1.1] }, '.... got the right output'); } foreach my $tree ( $tree, $pure ) { my $w = Forest::Tree::Writer::SimpleHTML->new(tree => $tree); isa_ok($w, 'Forest::Tree::Writer::SimpleHTML'); isa_ok($w->tree, 'Forest::Tree::Pure'); is($w->as_string, q{
  • 1.0
    • 1.1
    • 1.2
      • 1.2.1
  • 2.0
    • 2.1
  • 3.0
  • 4.0
    • 4.1
      • 4.1.1
}, '.... got the right output'); } foreach my $tree ( $tree, $pure ) { my $w = Forest::Tree::Writer::SimpleHTML->new( tree => $tree, node_formatter => sub { '' . (shift)->node . '' } ); isa_ok($w, 'Forest::Tree::Writer::SimpleHTML'); isa_ok($w->tree, 'Forest::Tree::Pure'); is($w->as_string, q{
  • 1.0
    • 1.1
    • 1.2
      • 1.2.1
  • 2.0
    • 2.1
  • 3.0
  • 4.0
    • 4.1
      • 4.1.1
}, '.... got the right output'); } __DATA__ 1.0 1.1 1.2 1.2.1 2.0 2.1 3.0 4.0 4.1 4.1.1 Forest-0.10/t/031_Tree_Writer_to_disk.t000644 000767 000767 00000003112 11323404233 020526 0ustar00stevanstevan000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 11; use Path::Class; BEGIN { use_ok('Forest::Tree'); use_ok('Forest::Tree::Reader::SimpleTextFile'); use_ok('Forest::Tree::Writer'); use_ok('Forest::Tree::Writer::SimpleASCII'); use_ok('Forest::Tree::Writer::SimpleHTML'); } my $file = Path::Class::File->new('031_Tree_Writer_to_disk.tree'); $file->touch; my $reader = Forest::Tree::Reader::SimpleTextFile->new; $reader->read(\*DATA); { my $w = Forest::Tree::Writer::SimpleASCII->new(tree => $reader->tree); isa_ok($w, 'Forest::Tree::Writer::SimpleASCII'); isa_ok($w->tree, 'Forest::Tree'); my $fh = $file->openw; $w->write($fh); $fh->close; is($file->slurp, q{1.0 1.1 1.2 1.2.1 2.0 2.1 3.0 4.0 4.1 4.1.1 }, '.... got the right output'); } $file->remove; $file->touch; { my $w = Forest::Tree::Writer::SimpleHTML->new(tree => $reader->tree); isa_ok($w, 'Forest::Tree::Writer::SimpleHTML'); isa_ok($w->tree, 'Forest::Tree'); my $fh = $file->openw; $w->write($fh); $fh->close; is($file->slurp, q{
  • 1.0
    • 1.1
    • 1.2
      • 1.2.1
  • 2.0
    • 2.1
  • 3.0
  • 4.0
    • 4.1
      • 4.1.1
}, '.... got the right output'); } $file->remove; __DATA__ 1.0 1.1 1.2 1.2.1 2.0 2.1 3.0 4.0 4.1 4.1.1 Forest-0.10/t/032_Tree_Writer_complex_ASCII.t000644 000767 000767 00000005036 11151777150 021473 0ustar00stevanstevan000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 9; BEGIN { use_ok('Forest::Tree'); use_ok('Forest::Tree::Reader::SimpleTextFile'); use_ok('Forest::Tree::Writer'); use_ok('Forest::Tree::Writer::ASCIIWithBranches'); }; my $reader = Forest::Tree::Reader::SimpleTextFile->new; $reader->read(\*DATA); { my $w = Forest::Tree::Writer::ASCIIWithBranches->new(tree => $reader->tree); isa_ok($w, 'Forest::Tree::Writer::ASCIIWithBranches'); isa_ok($w->tree, 'Forest::Tree'); # FOR DEBUGGIN #use Test::Differences; #eq_or_diff($w->as_string, is($w->as_string, q{root |---1.0 | |---1.1 | |---1.2 | |---1.2.1 |---2.0 | |---2.1 |---3.0 |---4.0 |---4.1 |---4.1.1 }, '.... got the right output'); } { my $tree = Forest::Tree->new( node => 'root', children => [ Forest::Tree->new( node => '1.0', children => [ Forest::Tree->new(node => '1.1'), Forest::Tree->new( node => '1.2', children => [ Forest::Tree->new(node => '1.2.1'), ] ) ] ), Forest::Tree->new( node => '2.0', children => [ Forest::Tree->new(node => '2.1') ] ), Forest::Tree->new(node => '3.0'), Forest::Tree->new( node => '4.0', children => [ Forest::Tree->new( node => '4.1', children => [ Forest::Tree->new(node => '4.1.1'), ] ) ] ), ] ); my $w = Forest::Tree::Writer::ASCIIWithBranches->new( tree => Forest::Tree->new(children => [ $tree ]) ); isa_ok($w, 'Forest::Tree::Writer::ASCIIWithBranches'); # FOR DEBUGGIN #use Test::Differences; #eq_or_diff($w->as_string, is($w->as_string, q{root |---1.0 | |---1.1 | |---1.2 | |---1.2.1 |---2.0 | |---2.1 |---3.0 |---4.0 |---4.1 |---4.1.1 }, '.... got the right output'); } __DATA__ root 1.0 1.1 1.2 1.2.1 2.0 2.1 3.0 4.0 4.1 4.1.1 Forest-0.10/t/033_Tree_Writer_incremental_build.t000644 000767 000767 00000005211 11151777163 022574 0ustar00stevanstevan000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 21; BEGIN { use_ok('Forest::Tree'); use_ok('Forest::Tree::Reader::SimpleTextFile'); use_ok('Forest::Tree::Writer'); use_ok('Forest::Tree::Writer::SimpleASCII'); use_ok('Forest::Tree::Writer::SimpleHTML'); }; my $tree = Forest::Tree->new( children => [ Forest::Tree->new(node => '1.0'), Forest::Tree->new(node => '2.0'), ] ); is($tree->get_child_at(0)->parent, $tree, '... correct parental relations'); is($tree->get_child_at(1)->parent, $tree, '... correct parental relations'); { my $w = Forest::Tree::Writer::SimpleASCII->new(tree => $tree); isa_ok($w, 'Forest::Tree::Writer::SimpleASCII'); is($w->as_string, q{1.0 2.0 }, '.... got the right output'); } $tree->add_child(Forest::Tree->new(node => '3.0')); { my $w = Forest::Tree::Writer::SimpleASCII->new(tree => $tree); isa_ok($w, 'Forest::Tree::Writer::SimpleASCII'); is($w->as_string, q{1.0 2.0 3.0 }, '.... got the right output'); } $tree->add_child(Forest::Tree->new(node => '4.0')); { my $w = Forest::Tree::Writer::SimpleASCII->new(tree => $tree); isa_ok($w, 'Forest::Tree::Writer::SimpleASCII'); is($w->as_string, q{1.0 2.0 3.0 4.0 }, '.... got the right output'); } $tree->get_child_at(0)->add_children( Forest::Tree->new(node => '1.1'), Forest::Tree->new(node => '1.2'), ); { my $w = Forest::Tree::Writer::SimpleASCII->new(tree => $tree); isa_ok($w, 'Forest::Tree::Writer::SimpleASCII'); is($w->as_string, q{1.0 1.1 1.2 2.0 3.0 4.0 }, '.... got the right output'); } $tree->get_child_at(0)->get_child_at(1)->add_children( Forest::Tree->new(node => '1.2.1'), ); { my $w = Forest::Tree::Writer::SimpleASCII->new(tree => $tree); isa_ok($w, 'Forest::Tree::Writer::SimpleASCII'); is($w->as_string, q{1.0 1.1 1.2 1.2.1 2.0 3.0 4.0 }, '.... got the right output'); } $tree->get_child_at(1)->add_children( Forest::Tree->new(node => '2.1'), ); { my $w = Forest::Tree::Writer::SimpleASCII->new(tree => $tree); isa_ok($w, 'Forest::Tree::Writer::SimpleASCII'); is($w->as_string, q{1.0 1.1 1.2 1.2.1 2.0 2.1 3.0 4.0 }, '.... got the right output'); } $tree->get_child_at(3)->add_children( Forest::Tree->new( node => '4.1', children => [ Forest::Tree->new(node => '4.1.1') ] ), ); { my $w = Forest::Tree::Writer::SimpleASCII->new(tree => $tree); isa_ok($w, 'Forest::Tree::Writer::SimpleASCII'); is($w->as_string, q{1.0 1.1 1.2 1.2.1 2.0 2.1 3.0 4.0 4.1 4.1.1 }, '.... got the right output'); } Forest-0.10/t/040_Tree_Indexer.t000644 000767 000767 00000003233 11323404233 017140 0ustar00stevanstevan000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 36; BEGIN { use_ok('Forest::Tree::Pure'); use_ok('Forest::Tree'); use_ok('Forest::Tree::Reader::SimpleTextFile'); use_ok('Forest::Tree::Indexer'); use_ok('Forest::Tree::Indexer::SimpleUIDIndexer'); }; { my $tree = Forest::Tree::Pure->new( node => 3, uid => "three", children => [ Forest::Tree::Pure->new( node => 10, uid => "ten", ), ], ); my $index = Forest::Tree::Indexer::SimpleUIDIndexer->new(tree => $tree); isa_ok($index, 'Forest::Tree::Indexer::SimpleUIDIndexer'); $index->build_index; my @keys = $index->get_index_keys; is_deeply([ sort @keys ], [sort qw(ten three)], '... got the right keys'); foreach my $key (@keys) { my $tree = $index->get_tree_at($key); isa_ok($tree, 'Forest::Tree::Pure'); is($tree->uid, $key, '... indexed by uid'); } } { my $reader = Forest::Tree::Reader::SimpleTextFile->new; isa_ok($reader, 'Forest::Tree::Reader::SimpleTextFile'); $reader->read(\*DATA); my $index = Forest::Tree::Indexer::SimpleUIDIndexer->new(tree => $reader->tree); isa_ok($index, 'Forest::Tree::Indexer::SimpleUIDIndexer'); $index->build_index; my @keys = $index->get_index_keys; is(scalar @keys, 11, '... got the right amount of keys'); foreach my $key (@keys) { my $tree = $index->get_tree_at($key); isa_ok($tree, 'Forest::Tree'); is($tree->uid, $key, '... indexed by uid'); } } __DATA__ 1.0 1.1 1.2 1.2.1 2.0 2.1 3.0 4.0 4.1 4.1.1 Forest-0.10/t/041_Tree_Indexer_w_custom_reader.t000644 000767 000767 00000002527 11151777213 022422 0ustar00stevanstevan000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 29; BEGIN { use_ok('Forest::Tree'); use_ok('Forest::Tree::Reader::SimpleTextFile'); use_ok('Forest::Tree::Indexer'); use_ok('Forest::Tree::Indexer::SimpleUIDIndexer'); }; { { package My::Tree::Reader; use Moose; extends 'Forest::Tree::Reader::SimpleTextFile'; sub create_new_subtree { shift; my $t = Forest::Tree->new(@_); $t->uid($t->node); $t; } __PACKAGE__->meta->make_immutable(); } my $reader = My::Tree::Reader->new; isa_ok($reader, 'My::Tree::Reader'); isa_ok($reader, 'Forest::Tree::Reader::SimpleTextFile'); $reader->read(\*DATA); my $index = Forest::Tree::Indexer::SimpleUIDIndexer->new(tree => $reader->tree); isa_ok($index, 'Forest::Tree::Indexer::SimpleUIDIndexer'); $index->build_index; my @keys = $index->get_index_keys; is(scalar @keys, 11, '... got the right amount of keys'); foreach my $key (@keys) { my $tree = $index->get_tree_at($key); isa_ok($tree, 'Forest::Tree'); next if $tree->is_root; is($tree->node, $key, '... got the right key match'); } } __DATA__ 1.0 1.1 1.2 1.2.1 2.0 2.1 3.0 4.0 4.1 4.1.1 Forest-0.10/t/060_Tree_Loader.t000644 000767 000767 00000004541 11151777230 016766 0ustar00stevanstevan000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 23; use Test::Exception; BEGIN { use_ok('Forest::Tree'); use_ok('Forest::Tree::Loader'); use_ok('Forest::Tree::Loader::SimpleUIDLoader'); }; my $data = [ { node => '1.0', uid => 1, parent_uid => 0 }, { node => '1.1', uid => 2, parent_uid => 1 }, { node => '1.2', uid => 3, parent_uid => 1 }, { node => '1.2.1', uid => 4, parent_uid => 3 }, { node => '2.0', uid => 5, parent_uid => 0 }, { node => '2.1', uid => 6, parent_uid => 5 }, { node => '3.0', uid => 7, parent_uid => 0 }, { node => '4.0', uid => 8, parent_uid => 0 }, { node => '4.1', uid => 9, parent_uid => 8 }, { node => '4.1.1', uid => 10, parent_uid => 9 }, ]; { my $loader = Forest::Tree::Loader::SimpleUIDLoader->new; isa_ok($loader, 'Forest::Tree::Loader::SimpleUIDLoader'); ok($loader->does('Forest::Tree::Loader'), '... loader does Forest::Tree::Loader'); my $tree = $loader->tree; isa_ok($tree, 'Forest::Tree'); ok($tree->is_root, '... tree is a root'); ok($tree->is_leaf, '... tree is a leaf'); is($tree->child_count, 0, '... tree has no children'); lives_ok { $loader->load($data); } '... loaded the tree'; ok($tree->is_root, '... tree is a root'); ok(!$tree->is_leaf, '... tree is not a leaf'); is($tree->child_count, 4, '... tree has 4 children'); is($tree->get_child_at(0)->node, '1.0', '... got the right node'); is($tree->get_child_at(0)->get_child_at(0)->node, '1.1', '... got the right node'); is($tree->get_child_at(0)->get_child_at(1)->node, '1.2', '... got the right node'); is($tree->get_child_at(0)->get_child_at(1)->get_child_at(0)->node, '1.2.1', '... got the right node'); is($tree->get_child_at(1)->node, '2.0', '... got the right node'); is($tree->get_child_at(1)->get_child_at(0)->node, '2.1', '... got the right node'); is($tree->get_child_at(2)->node, '3.0', '... got the right node'); is($tree->get_child_at(3)->node, '4.0', '... got the right node'); is($tree->get_child_at(3)->get_child_at(0)->node, '4.1', '... got the right node'); is($tree->get_child_at(3)->get_child_at(0)->get_child_at(0)->node, '4.1.1', '... got the right node'); } Forest-0.10/t/061_Tree_Loader_with_metadata.t000644 000767 000767 00000006530 11151777243 021666 0ustar00stevanstevan000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 30; use Test::Exception; BEGIN { use_ok('Forest::Tree'); use_ok('Forest::Tree::Loader'); use_ok('Forest::Tree::Loader::SimpleUIDLoader'); }; my $data = [ { node => '1.0', uid => 1, parent_uid => 0 }, { node => '1.1', uid => 2, parent_uid => 1 }, { node => '1.2', uid => 3, parent_uid => 1 }, { node => '1.2.1', uid => 4, parent_uid => 3 }, { node => '2.0', uid => 5, parent_uid => 0 }, { node => '2.1', uid => 6, parent_uid => 5 }, { node => '3.0', uid => 7, parent_uid => 0 }, { node => '4.0', uid => 8, parent_uid => 0 }, { node => '4.1', uid => 9, parent_uid => 8 }, { node => '4.1.1', uid => 10, parent_uid => 9 }, ]; { package My::Tree; use Moose; extends 'Forest::Tree'; with 'Forest::Tree::Roles::MetaData'; } { package My::Tree::Loader::WithMetaData; use Moose; extends 'Forest::Tree::Loader::SimpleUIDLoader'; with 'Forest::Tree::Roles::LoadWithMetaData'; has '+tree' => (default => sub { My::Tree->new }); } { my $loader = My::Tree::Loader::WithMetaData->new( metadata => { 1 => { name => 'one' }, 5 => { name => 'two' }, 7 => { name => 'three' }, 8 => { name => 'four' }, } ); isa_ok($loader, 'My::Tree::Loader::WithMetaData'); isa_ok($loader, 'Forest::Tree::Loader::SimpleUIDLoader'); ok($loader->does('Forest::Tree::Loader'), '... loader does Forest::Tree::Loader'); ok($loader->does('Forest::Tree::Roles::LoadWithMetaData'), '... loader does LoadWithMetaData'); my $tree = $loader->tree; isa_ok($tree, 'My::Tree'); isa_ok($tree, 'Forest::Tree'); ok($tree->is_root, '... tree is a root'); ok($tree->is_leaf, '... tree is a leaf'); is($tree->child_count, 0, '... tree has no children'); lives_ok { $loader->load($data); } '... loaded the tree'; ok($tree->is_root, '... tree is a root'); ok(!$tree->is_leaf, '... tree is not a leaf'); is($tree->child_count, 4, '... tree has 4 children'); is($tree->get_child_at(0)->node, '1.0', '... got the right node'); is_deeply($tree->get_child_at(0)->metadata, { name => 'one' }, '... got the right metadata'); is($tree->get_child_at(0)->get_child_at(0)->node, '1.1', '... got the right node'); is($tree->get_child_at(0)->get_child_at(1)->node, '1.2', '... got the right node'); is($tree->get_child_at(0)->get_child_at(1)->get_child_at(0)->node, '1.2.1', '... got the right node'); is($tree->get_child_at(1)->node, '2.0', '... got the right node'); is_deeply($tree->get_child_at(1)->metadata, { name => 'two' }, '... got the right metadata'); is($tree->get_child_at(1)->get_child_at(0)->node, '2.1', '... got the right node'); is($tree->get_child_at(2)->node, '3.0', '... got the right node'); is_deeply($tree->get_child_at(2)->metadata, { name => 'three' }, '... got the right metadata'); is($tree->get_child_at(3)->node, '4.0', '... got the right node'); is_deeply($tree->get_child_at(3)->metadata, { name => 'four' }, '... got the right metadata'); is($tree->get_child_at(3)->get_child_at(0)->node, '4.1', '... got the right node'); is($tree->get_child_at(3)->get_child_at(0)->get_child_at(0)->node, '4.1.1', '... got the right node'); } Forest-0.10/t/pod.t000644 000767 000767 00000000257 11151776514 015002 0ustar00stevanstevan000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); Forest-0.10/lib/Forest/000755 000767 000120 00000000000 12254320621 015330 5ustar00stevanadmin000000 000000 Forest-0.10/lib/Forest.pm000644 000767 000767 00000004245 12254320225 016124 0ustar00stevanstevan000000 000000 package Forest; use Moose (); our $VERSION = '0.10'; our $AUTHORITY = 'cpan:STEVAN'; 1; __END__ =pod =head1 NAME Forest - A collection of n-ary tree related modules =head1 DESCRIPTION Forest is intended to be a replacement for the L family of modules, and fixes many of the issues that have always bothered me about them. It is by no means a complete replacement yet, but should eventually grow to become that. For more information please refer to the individual module documentation, starting with L. =head1 TODO =over 4 =item More documentation This is 0.10 so it is (still) lacking quite a bit of docs (I am being really lazy sorry). Although I invite people to read the source, it is quite simple really. =item More tests The coverage is in the low 90s, but there is still a lot of behavioral stuff that could use some testing too. =back =head1 SEE ALSO =over 4 =item L I wrote this module a few years ago and I had served me well, but recently I find myself getting frustrated with some of the uglier bits of this module. So Forest is a re-write of this module. =item L This is an ambitious project to replace all the Tree related modules with a single core implementation. There is some good code in here, but the project seems to be very much on the back-burner at this time. =item O'Caml port of Forest Ask me about the O'Caml port of this module, it is also sitting on my hard drive waiting for release. It actually helped quite a bit in terms of helping me settle on the APIs for this module. Static typing can be very helpful sometimes. =back =head1 BUGS All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. =head1 AUTHOR Stevan Little Estevan.little@iinteractive.comE With contributions from: Yuval (nothingmuch) Kogman Guillermo (groditi) Roditi Florian (rafl) Ragwitz Jesse (doy) Luehrs =head1 COPYRIGHT AND LICENSE Copyright 2008-2014 Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Forest-0.10/lib/Forest/Tree/000755 000767 000120 00000000000 12254320621 016227 5ustar00stevanadmin000000 000000 Forest-0.10/lib/Forest/Tree.pm000644 000767 000120 00000016631 12254320225 016574 0ustar00stevanadmin000000 000000 package Forest::Tree; use Moose; use Scalar::Util 'reftype', 'refaddr'; use List::Util 'sum', 'max'; our $VERSION = '0.10'; our $AUTHORITY = 'cpan:STEVAN'; extends qw(Forest::Tree::Pure); #has '+node' => ( is => 'rw' ); has 'node' => ( traits => [qw(StorableClone)], is => 'rw', isa => 'Item', ); sub set_node { my ( $self, $new ) = @_; $self->node($new); $self; } has 'parent' => ( traits => [qw(NoClone)], reader => 'parent', writer => '_set_parent', predicate => 'has_parent', clearer => 'clear_parent', isa => 'Maybe[Forest::Tree]', weak_ref => 1, handles => { 'add_sibling' => 'add_child', 'get_sibling_at' => 'get_child_at', 'insert_sibling_at' => 'insert_child_at', }, ); #has '+children' => ( # is => 'rw', has 'children' => ( traits => [qw(Array Clone)], is => 'rw', isa => 'ArrayRef[Forest::Tree]', lazy => 1, default => sub { [] }, handles => { get_child_at => 'get', child_count => 'count', }, trigger => sub { my ($self, $children) = @_; foreach my $child (@$children) { $child->_set_parent($self); $self->clear_height if $self->has_height; $self->clear_size if $self->has_size; } } ); after 'clear_size' => sub { my $self = shift; $self->parent->clear_size if $self->has_parent && $self->parent->has_size; }; after 'clear_height' => sub { my $self = shift; $self->parent->clear_height if $self->has_parent && $self->parent->has_height; }; ## informational sub is_root { !(shift)->has_parent } ## depth sub depth { ((shift)->parent || return -1)->depth + 1 } ## child management sub add_child { my ($self, $child) = @_; (blessed($child) && $child->isa(ref $self)) || confess "Child parameter must be a " . ref($self) . " not (" . (defined $child ? $child : 'undef') . ")"; $child->_set_parent($self); $self->clear_height if $self->has_height; $self->clear_size if $self->has_size; push @{ $self->children } => $child; $self; } sub replace { my ( $self, $replacement ) = @_; confess "Can't replace root" if $self->is_root; $self->parent->set_child_at( $self->get_index_in_siblings, $replacement ); return $replacement; } sub add_children { my ($self, @children) = @_; $self->add_child($_) for @children; return $self; } sub set_child_at { my ( $self, $index, $child ) = @_; (blessed($child) && $child->isa(ref $self)) || confess "Child parameter must be a " . ref($self) . " not (" . (defined $child ? $child : 'undef') . ")"; $self->clear_height if $self->has_height; $self->clear_size if $self->has_size; my $children = $self->children; $children->[$index]->clear_parent; $children->[$index] = $child; $child->_set_parent($self); $self; } sub insert_child_at { my ($self, $index, $child) = @_; (blessed($child) && $child->isa(ref $self)) || confess "Child parameter must be a " . ref($self) . " not (" . (defined $child ? $child : 'undef') . ")"; $child->_set_parent($self); $self->clear_height if $self->has_height; $self->clear_size if $self->has_size; splice @{ $self->children }, $index, 0, $child; $self; } sub remove_child_at { my ($self, $index) = @_; $self->clear_height if $self->has_height; $self->clear_size if $self->has_size; my $child = splice @{ $self->children }, $index, 1; $child->clear_parent; $child; } ##siblings sub siblings { my $self = shift; return [] unless $self->has_parent; [ grep { $self->uid ne $_->uid } @{ $self->parent->children } ]; } sub get_index_in_siblings { my ($self) = @_; return -1 if $self->is_root; $self->parent->get_child_index($self); } ## cloning sub clone_and_detach { shift->clone(@_) } sub to_pure_tree { my $self = shift; $self->reconstruct_with_class("Forest::Tree::Pure"); } sub to_mutable_tree { my $self = shift; return $self; } __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =pod =head1 NAME Forest::Tree - An n-ary tree =head1 SYNOPSIS use Forest::Tree; my $t = Forest::Tree->new( node => 1, children => [ Forest::Tree->new( node => 1.1, children => [ Forest::Tree->new(node => 1.1.1), Forest::Tree->new(node => 1.1.2), Forest::Tree->new(node => 1.1.3), ] ), Forest::Tree->new(node => 1.2), Forest::Tree->new( node => 1.3, children => [ Forest::Tree->new(node => 1.3.1), Forest::Tree->new(node => 1.3.2), ] ), ] ); $t->traverse(sub { my $t = shift; print((' ' x $t->depth) . ($t->node || '\undef') . "\n"); }); =head1 DESCRIPTION This module is a basic n-ary tree, it provides most of the functionality of Tree::Simple, whatever is missing will be added eventually. This class inherits from L>, but all shared methods and attributes are documented in both classes. =head1 ATTRIBUTES =over 4 =item I =item I =item I =over 4 =item B =item B<_set_parent> =item B =item B =back =item I =over 4 =item B Return the child at this position. (zero-base index) =item B Returns the number of children this tree has =back =item I =over 4 =item B =item B =item B =back =item I =over 4 =item B =item B =item B =back =back =head1 METHODS =over 4 =item B True if the current tree has no parent =item B True if the current tree has no children =item B Return the depth of this tree. Root has a depth of -1 =item B =item B Add a new child. The $child must be a C =item B Insert a child at this position. (zero-base index) =item B Remove the child at this position. (zero-base index) =item B Takes a reference to a subroutine and traverses the tree applying this subroutine to every descendant. =item B Returns an array reference of all siblings (not including us) =item B Invokes C with L. =item B Returns the invocant (without cloning). =item B See L. This variant will B clone the parent, but return a clone of the subtree that is detached. =item B Returns the index of the tree in the list of children. Equivalent to calling C<$tree->parent->get_child_index($tree)>. Returns -1 if the node has no parent (the root node). =back =head1 BUGS All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. =head1 AUTHOR Stevan Little Estevan.little@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2008-2014 Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Forest-0.10/lib/Forest/Tree/Builder/000755 000767 000120 00000000000 12254320621 017615 5ustar00stevanadmin000000 000000 Forest-0.10/lib/Forest/Tree/Builder.pm000644 000767 000767 00000005054 12254320225 020410 0ustar00stevanstevan000000 000000 package Forest::Tree::Builder; use Moose::Role; our $VERSION = '0.10'; our $AUTHORITY = 'cpan:STEVAN'; with qw(Forest::Tree::Constructor); has 'tree' => ( is => 'ro', writer => "_tree", isa => 'Forest::Tree::Pure', lazy_build => 1, ); has tree_class => ( isa => "ClassName", is => "ro", reader => "_tree_class", default => "Forest::Tree", ); # horrible horrible kludge to satisfy 'requires' without forcing 'sub # tree_class {}' in every single class. God i hate roles and attributes sub tree_class { shift->_tree_class(@_) } sub _build_tree { my $self = shift; $self->create_new_subtree( children => $self->subtrees, ); } has subtrees => ( isa => "ArrayRef[Forest::Tree::Pure]", is => "ro", lazy_build => 1, ); requires "_build_subtrees"; # ex: set sw=4 et: no Moose::Role; 1; __END__ =head1 NAME Forest::Tree::Builder - An abstract role for bottom up tree reader =head1 SYNOPSIS package MyBuilder; use Moose; with qw(Forest::Tree::Builder); # implement required builder: sub _build_subtrees { return [ $self->create_new_subtree( ... ), # probably a recursive process ]; } my $builder = MyBuilder->new( tree_class => ..., ... ); my $tree = $builder->tree; =head1 DESCRIPTION L replaces L and L with a bottom up construction approach, which is also suitable for constructing L derived trees without excessive cloning. It provides a declarative API instead of an imperative one, where C is lazily constructed on the first use, instead of being constructed immediately and "filled in" by the C method. =head1 METHODS =over 4 =item create_new_subtree Implemented by L =item _build_tree Constructs a root node by using the top level C list as the children. =item _build_subtrees Build the subtrees. Abstract method that should return an array ref of L derived objects. =back =head1 SEE ALSO L =head1 BUGS All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. =head1 AUTHOR Yuval Kogman =head1 COPYRIGHT AND LICENSE Copyright 2008-2014 Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Forest-0.10/lib/Forest/Tree/Constructor.pm000644 000767 000767 00000004710 12254320225 021345 0ustar00stevanstevan000000 000000 package Forest::Tree::Constructor; use Moose::Role; our $VERSION = '0.10'; our $AUTHORITY = 'cpan:STEVAN'; requires "tree_class"; sub create_new_subtree { my ($self, %options) = @_; my $node = $options{node}; if (blessed($node) && $node->isa('Forest::Tree::Pure')) { # when node is an tree object we assume that it's a prototype of a tree # node to be filled in # remove meaningless keys delete $options{node}; delete $options{children} if exists $options{children} and not @{ $options{children} }; # nothing left to be done if the option cleanup deleted all keys return $node unless keys %options; if ( $node->child_count == 0 ) { if ( $node->isa("Forest::Tree") ) { # mutable trees get modified foreach my $key ( keys %options ) { $node->$key( $options{$key} ); } return $node; } else { # pure trees get cloned return $node->clone(%options); } } else { # i suppose $options{children} could be appended to $node->children # if there are any, but that doesn't really make sense IMHO, might # as well write your own builder at that point instead of kludging # it with the parser callback for the simple text loader or something confess("Can't override children from proto node"); } } else { return $self->tree_class->new(%options); } } # ex: set sw=4 et no Moose::Role; 1; __END__ =head1 NAME Forest::Tree::Constructor - An abstract role for tree factories =head1 SYNOPSIS with qw(Forest::Tree::Constructor); sub tree_class { ... } sub foo { $self->create_new_subtree( ... ) } =head1 DESCRIPTION This role provides the C method as required by L and L/L. See L for the reccomended usage. =head1 BUGS All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. =head1 AUTHOR Yuval Kogman =head1 COPYRIGHT AND LICENSE Copyright 2008-2014 Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Forest-0.10/lib/Forest/Tree/Indexer/000755 000767 000120 00000000000 12254320621 017625 5ustar00stevanadmin000000 000000 Forest-0.10/lib/Forest/Tree/Indexer.pm000644 000767 000120 00000002672 12254320225 020172 0ustar00stevanadmin000000 000000 package Forest::Tree::Indexer; use Moose::Role; our $VERSION = '0.10'; our $AUTHORITY = 'cpan:STEVAN'; has 'tree' => ( is => 'rw', isa => 'Forest::Tree::Pure', ); has 'index' => ( traits => ['Hash'], is => 'rw', isa => 'HashRef[Forest::Tree::Pure]', lazy => 1, default => sub { {} }, handles => { get_tree_at => 'get', has_tree_at => 'exists', clear_index => 'clear', get_index_keys => 'keys', } ); requires 'build_index'; sub get_root { (shift)->tree } no Moose::Role; 1; __END__ =pod =head1 NAME Forest::Tree::Indexer - An abstract role for tree indexers =head1 DESCRIPTION This is an abstract role for tree writers. =head1 ATTRIBUTES =over 4 =item I =item I =over 4 =item B =item B =item B =back =back =head1 REQUIRED METHODS =over 4 =item B =back =head1 METHODS =over 4 =item B =back =head1 BUGS All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. =head1 AUTHOR Stevan Little Estevan.little@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2008-2014 Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Forest-0.10/lib/Forest/Tree/Loader/000755 000767 000120 00000000000 12254320621 017435 5ustar00stevanadmin000000 000000 Forest-0.10/lib/Forest/Tree/Loader.pm000644 000767 000767 00000003172 12254320225 020227 0ustar00stevanstevan000000 000000 package Forest::Tree::Loader; use Moose::Role; our $VERSION = '0.10'; our $AUTHORITY = 'cpan:STEVAN'; with 'Forest::Tree::Constructor'; has 'tree' => ( is => 'ro', writer => "_tree", isa => 'Forest::Tree', lazy => 1, # FIXME should really be shift->create_new_subtree() but that breaks # compatibility when this method is overridden and shouldn't apply to the # root node... anyway, Loader should be deprecated anyway default => sub { Forest::Tree->new }, ); # more compatibility, the tree class is determined by the class of the root # which might not be Forest::Tree in subclasses or with explicit # ->new( tree => ... ) has tree_class => ( isa => "ClassName", is => "ro", reader => "_tree_class", default => sub { ref shift->tree }, ); sub tree_class { shift->_tree_class(@_) } requires 'load'; no Moose::Role; 1; __END__ =pod =head1 NAME Forest::Tree::Loader - An abstract role for loading trees =head1 DESCRIPTION B. This is an abstract role to be used for loading trees from =head1 METHODS =over 4 =item B<> =back =head1 BUGS All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. =head1 AUTHOR Stevan Little Estevan.little@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2008-2014 Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Forest-0.10/lib/Forest/Tree/Pure.pm000644 000767 000120 00000026722 12254320225 017511 0ustar00stevanadmin000000 000000 package Forest::Tree::Pure; use Moose; our $VERSION = '0.10'; our $AUTHORITY = 'cpan:STEVAN'; use Scalar::Util 'reftype', 'refaddr'; use List::Util 'sum', 'max'; with qw(MooseX::Clone); has 'node' => ( is => 'ro', isa => 'Item', predicate => 'has_node', ); has 'uid' => ( is => 'rw', isa => 'Value', lazy => 1, default => sub { (overload::StrVal($_[0]) =~ /\((.*?)\)$/)[0] }, ); has 'children' => ( traits => ['Array'], is => 'ro', isa => 'ArrayRef[Forest::Tree::Pure]', lazy => 1, default => sub { [] }, handles => { get_child_at => 'get', child_count => 'count', }, ); has 'size' => ( traits => [qw(NoClone)], is => 'ro', isa => 'Int', lazy_build => 1, ); sub _build_size { my $self = shift; if ( $self->is_leaf ) { return 1; } else { return 1 + sum map { $_->size } @{ $self->children }; } } has 'height' => ( traits => [qw(NoClone)], is => 'ro', isa => 'Int', lazy_build => 1, ); sub _build_height { my $self = shift; if ( $self->is_leaf ) { return 0; } else { return 1 + max map { $_->height } @{ $self->children }; } } ## informational sub is_leaf { (shift)->child_count == 0 } ## traversal sub traverse { my ($self, @args) = @_; $_->visit(@args) for @{ $self->children }; } sub visit { my ( $self, $f, @args ) = @_; $self->fmap_cont(sub { my ( $tree, $cont, @args ) = @_; $tree->$f(@args); $cont->(); }); } sub fmap_cont { my ( $self, @args ) = @_; unshift @args, "callback" if @args % 2 == 1; my %args = ( depth => 0, path => [], index_path => [], @args ); my $f = $args{callback}; (defined($f)) || confess "Cannot traverse without traversal function"; (!ref($f) or reftype($f) eq "CODE") || confess "Traversal function must be a CODE reference or method name, not: $f"; $self->$f( sub { my ( @inner_args ) = @_; unshift @inner_args, "callback" if @inner_args % 2 == 1; my $children = $args{children} || $self->children; my %child_args = ( %args, depth => $args{depth} + 1, path => [ @{ $args{path} }, $self ], parent => $self, @inner_args ); my @index_path = @{ $args{index_path} }; my $i = 0; map { my $index = $i++; $_->fmap_cont( %child_args, index => $index, index_path => [ @index_path, $index ], ) } @$children; }, %args, ); } sub locate { my ( $self, @path ) = @_; my @nodes = $self->descend(@path); return $nodes[-1]; } sub descend { my ( $self, @path ) = @_; if ( @path ) { my ( $head, @tail ) = @path; if ( my $child = $self->get_child_at($head) ) { return ( $self, $child->descend(@tail) ); } else { confess "No such child $head"; } } else { return $self; } } sub transform { my ( $self, $path, $method, @args ) = @_; if ( @$path ) { my ( $i, @path ) = @$path; my $targ = $self->get_child_at($i); my $transformed = $targ->transform(\@path, $method, @args); if ( refaddr($transformed) == refaddr($targ) ) { return $self; } else { return $self->set_child_at( $i => $transformed ); } } else { return $self->$method(@args); } } sub set_node { my ( $self, $node ) = @_; $self->clone( node => $node ); } sub replace { my ( $self, $replacement ) = @_; return $replacement; } sub add_children { my ( $self, @additional_children ) = @_; foreach my $child ( @additional_children ) { (blessed($child) && $child->isa(ref $self)) || confess "Child parameter must be a " . ref($self) . " not (" . (defined $child ? $child : 'undef') . ")"; } my @children = @{ $self->children }; push @children, @additional_children; return $self->clone( children => \@children ); } sub add_child { my ( $self, $child ) = @_; $self->add_children($child); } sub set_child_at { my ( $self, $index, $child ) = @_; (blessed($child) && $child->isa(ref $self)) || confess "Child parameter must be a " . ref($self) . " not (" . (defined $child ? $child : 'undef') . ")"; my @children = @{ $self->children }; $children[$index] = $child; $self->clone( children => \@children ); } sub remove_child_at { my ( $self, $index ) = @_; my @children = @{ $self->children }; confess "No child at index '$index'" if @children <= $index; splice @children, $index, 1; $self->clone( children => \@children ); } sub insert_child_at { my ( $self, $index, $child ) = @_; (blessed($child) && $child->isa('Forest::Tree::Pure')) || confess "Child parameter must be a Forest::Tree::Pure not (" . (defined $child ? $child : 'undef') . ")"; my @children = @{ $self->children }; confess "'$index' is out of bounds" if @children < $index; splice @children, $index, 0, $child; $self->clone( children => \@children ); } sub get_child_index { my ( $self, $child ) = @_; my $index = 0; foreach my $sibling (@{ $self->children }) { (refaddr($sibling) eq refaddr($child)) && return $index; $index++; } return; } sub reconstruct_with_class { my ( $self, $class ) = @_; confess "No class provided" unless defined($class); return $class->new( node => $self->node, children => [ map { $_->reconstruct_with_class($class) } @{ $self->children }, ], ); } sub to_pure_tree { my $self = shift; return $self; } sub to_mutable_tree { my $self = shift; $self->reconstruct_with_class("Forest::Tree"); } __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =pod =head1 NAME Forest::Tree::Pure - An n-ary tree =head1 SYNOPSIS use Forest::Tree; my $t = Forest::Tree::Pure->new( node => 1, children => [ Forest::Tree::Pure->new( node => 1.1, children => [ Forest::Tree::Pure->new(node => 1.1.1), Forest::Tree::Pure->new(node => 1.1.2), Forest::Tree::Pure->new(node => 1.1.3), ] ), Forest::Tree::Pure->new(node => 1.2), Forest::Tree::Pure->new( node => 1.3, children => [ Forest::Tree::Pure->new(node => 1.3.1), Forest::Tree::Pure->new(node => 1.3.2), ] ), ] ); $t->traverse(sub { my $t = shift; print((' ' x $t->depth) . ($t->node || '\undef') . "\n"); }); =head1 DESCRIPTION This module is a base class for L providing functionality for immutable trees. It can be used independently for trees that require sharing of children between parents. There is no single authoritative parent (no upward links at all), and changing of data is not supported. This class is appropriate when many tree roots share the same children (e.g. in a versioned tree). This class is strictly a DAG, wheras L produces a graph with back references =head1 ATTRIBUTES =over 4 =item I =item I =over 4 =item B Return the child at this position. (zero-base index) =item B Returns the number of children this tree has =back =item I =over 4 =item B =item B =back =item I =over 4 =item B =item B =back =back =head1 METHODS =over 4 =item B True if the current tree has no children =item B Takes a reference to a subroutine and traverses the tree applying this subroutine to every descendant. (But not the root) =item B Traverse the entire tree, including the root. =item B A CPS form of C that lets you control when and how data flows from the children. It takes a callback in the form: sub { my ( $tree, $cont, @args ) = @_; ... } and C<$cont> is a code ref that when invoked will apply that same function to the children of C<$tree>. This allows you to do things like computing the sum of all the node values in a tree, for instance: use List::Util qw(sum); my $sum = $tree->fmap_cont(sub { my ( $tree, $cont ) = @_; return sum( $tree->node, $cont->() ); }); And also allows to stop traversal at a given point. =item B =item B Create a new tree node with the children appended. The children must inherit C Note that this method does B mutate the tree, instead it clones and returns a tree with the augmented list of children. =item B Insert a child at this position. (zero-base index) Returns a derived tree with overridden children. =item B Replaces the child at C<$index> with C<$child>. =item B Remove the child at this position. (zero-base index) Returns a derived tree with overridden children. =item B Find a child using a path of child indexes. These two examples return the same object: $tree->get_child_at(0)->get_child_at(1)->get_child_at(0); $tree->locate(0, 1, 0); =item B Like C except that it returns every object in the path, not just the leaf. =item C Performs a lookup on C<@path>, applies the method C<$method> with C<@args> to the located node, and clones the path to the parent returning a derived tree. This method is also implemented in L by mutating the tree in place and returning the original tree, so the same transformations should work on both pure trees and mutable ones. This code: my $new = $root->transform([ 1, 3 ], insert_child_at => 3, $new_child); will locate the child at the path C<[ 1, 3 ]>, call C on it, creating a new version of C<[ 1, 3 ]>, and then return a cloned version of C<[ 1 ]> and the root node recursively, such that C<$new> appears to be a mutated C<$root>. =item set_node $new Returns a clone of the tree node with the node value changed. =item C Returns the argument. This is useful when used with C. =item B Provided by L. Deeply clones the entire tree. Subclasses should use L traits to specify the correct cloning behavior for additional attributes if cloning is used. =item B Recursively recreates the tree by passing constructor arguments to C<$class>. Does not use C. =item B Invokes C with L as the argument. =item B Returns the invocant. =item B Returns the index of C<$child> in C or undef if it isn't a child of the current tree. =back =head1 BUGS All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. =head1 AUTHOR Yuval Kogman =head1 COPYRIGHT AND LICENSE Copyright 2008-2014 Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Forest-0.10/lib/Forest/Tree/Reader/000755 000767 000120 00000000000 12254320621 017431 5ustar00stevanadmin000000 000000 Forest-0.10/lib/Forest/Tree/Reader.pm000644 000767 000767 00000002424 12254320225 020222 0ustar00stevanstevan000000 000000 package Forest::Tree::Reader; use Moose::Role; our $VERSION = '0.10'; our $AUTHORITY = 'cpan:STEVAN'; with 'Forest::Tree::Loader'; requires 'read'; # satisfy the Loader interface here ... sub load { my $self = shift; $self->read(@_); } no Moose::Role; 1; __END__ =pod =head1 NAME Forest::Tree::Reader - An abstract role for top down tree reader =head1 DESCRIPTION B. This is an abstract role for tree readers. Tree readers are also Tree loaders, that is why this module also does the L role. =head1 ATTRIBUTES =over 4 =item I =back =head1 REQUIRED METHODS =over 4 =item B =back =head1 METHODS =over 4 =item B This satisfies the L interface. =back =head1 BUGS All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. =head1 AUTHOR Stevan Little Estevan.little@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2008-2014 Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Forest-0.10/lib/Forest/Tree/Roles/000755 000767 000120 00000000000 12254320621 017313 5ustar00stevanadmin000000 000000 Forest-0.10/lib/Forest/Tree/Writer/000755 000767 000120 00000000000 12254320621 017503 5ustar00stevanadmin000000 000000 Forest-0.10/lib/Forest/Tree/Writer.pm000644 000767 000767 00000002116 12254320225 020272 0ustar00stevanstevan000000 000000 package Forest::Tree::Writer; use Moose::Role; our $VERSION = '0.10'; our $AUTHORITY = 'cpan:STEVAN'; has 'tree' => ( is => 'rw', isa => 'Forest::Tree::Pure', required => 1, ); requires 'as_string'; sub write { my ($self, $fh) = @_; print $fh $self->as_string; } no Moose::Role; 1; __END__ =pod =head1 NAME Forest::Tree::Writer - An abstract role for tree writers =head1 DESCRIPTION This is an abstract role for tree writers. =head1 ATTRIBUTES =over 4 =item I =back =head1 REQUIRED METHODS =over 4 =item B =back =head1 METHODS =over 4 =item B =back =head1 BUGS All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. =head1 AUTHOR Stevan Little Estevan.little@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2008-2014 Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Forest-0.10/lib/Forest/Tree/Writer/ASCIIWithBranches.pm000644 000767 000767 00000004053 12254320225 023426 0ustar00stevanstevan000000 000000 package Forest::Tree::Writer::ASCIIWithBranches; use Moose; our $VERSION = '0.10'; our $AUTHORITY = 'cpan:STEVAN'; with 'Forest::Tree::Writer', 'Forest::Tree::Roles::HasNodeFormatter'; sub as_string { my ($self) = @_; my $out = ''; my @vert_dashes; $self->tree->traverse(sub { my $t = shift; $out .= $self->_process_node($t, \@vert_dashes); }); return $out; } sub _process_node { my ($self, $t, $vert_dashes) = @_; my $depth = $t->depth; my $sibling_count = $t->is_root ? 1 : $t->parent->child_count; my @indent = map { $vert_dashes->[$_] || " " } 0 .. $depth - 1; @$vert_dashes = ( @indent, ($sibling_count == 1 ? (" ") : (" |")) ); if ($sibling_count == ($t->get_index_in_siblings + 1)) { $vert_dashes->[$depth] = " "; } return ((join "" => @indent[1 .. $#indent]) . ($depth ? " |---" : "") . $self->format_node($t) . "\n"); } __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =pod =head1 NAME Forest::Tree::Writer::ASCIIWithBranches - A slightly more complex ASCII writer =head1 SYNOPSIS use Forest::Tree::Writer::ASCIIWithBranches; my $w = Forest::Tree::Writer::ASCIIWithBranches->new(tree => $tree); print $w->as_string; # outputs .... # root # |---1.0 # | |---1.1 # | |---1.2 # | |---1.2.1 # |---2.0 # | |---2.1 # |---3.0 # |---4.0 # |---4.1 # |---4.1.1 =head1 DESCRIPTION =head1 METHODS =over 4 =item B<> =back =head1 BUGS All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. =head1 AUTHOR Stevan Little Estevan.little@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2008-2014 Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Forest-0.10/lib/Forest/Tree/Writer/SimpleASCII.pm000644 000767 000767 00000002526 12254320225 022301 0ustar00stevanstevan000000 000000 package Forest::Tree::Writer::SimpleASCII; use Moose; our $VERSION = '0.10'; our $AUTHORITY = 'cpan:STEVAN'; with 'Forest::Tree::Writer', 'Forest::Tree::Roles::HasNodeFormatter'; sub as_string { my ($self) = @_; my $out; return join( "", map { "$_\n" } $self->tree->fmap_cont(sub { my ( $t, $cont, %args ) = @_; if ( $t->has_node ) { return ( $self->format_node($t), map { " $_" } $cont->(), ); } else { return $cont->(); } }), ); } __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =pod =head1 NAME Forest::Tree::Writer::SimpleASCII - A simple ASCII writer for Forest::Tree heirarchies =head1 DESCRIPTION This is a simple writer which draws a tree in ASCII. =head1 METHODS =over 4 =item B =back =head1 BUGS All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. =head1 AUTHOR Stevan Little Estevan.little@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2008-2014 Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Forest-0.10/lib/Forest/Tree/Writer/SimpleHTML.pm000644 000767 000767 00000002514 12254320225 022212 0ustar00stevanstevan000000 000000 package Forest::Tree::Writer::SimpleHTML; use Moose; our $VERSION = '0.10'; our $AUTHORITY = 'cpan:STEVAN'; with 'Forest::Tree::Writer', 'Forest::Tree::Roles::HasNodeFormatter'; sub as_string { my ($self) = @_; return join( "", map { "$_\n" } $self->tree->fmap_cont(sub { my ( $t, $cont, %args ) = @_; return ( ( $t->has_node ? ( '
  • ' . $self->format_node($t) . '
    • ' ) : () ), ( $t->child_count ? ( '
      ', ( map { " $_" } $cont->() ), '
    ' ) : () ), ); }), ); } __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =pod =head1 NAME Forest::Tree::Writer::SimpleHTML - A simple HTML writer for Forest::Tree heirarchies =head1 DESCRIPTION This is a simple writer which draws a tree as an HTML unordered list. =head1 METHODS =over 4 =item B =back =head1 BUGS All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. =head1 AUTHOR Stevan Little Estevan.little@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2008-2014 Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Forest-0.10/lib/Forest/Tree/Roles/HasNodeFormatter.pm000644 000767 000767 00000002054 12254320225 023310 0ustar00stevanstevan000000 000000 package Forest::Tree::Roles::HasNodeFormatter; use Moose::Role; our $VERSION = '0.10'; our $AUTHORITY = 'cpan:STEVAN'; has 'node_formatter' => ( is => 'rw', isa => 'CodeRef|Str', lazy => 1, default => sub { sub { (shift)->node || 'undef' } } ); sub format_node { my ( $self, $node, @args ) = @_; my $fmt = $self->node_formatter; $node->$fmt(@args); } no Moose::Role; 1; __END__ =pod =head1 NAME Forest::Tree::Roles::HasNodeFormatter - Simple role for custom node formatters =head1 DESCRIPTION Simple role for nodes that have custom formatters =head1 BUGS All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. =head1 AUTHOR Stevan Little Estevan.little@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2008-2014 Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Forest-0.10/lib/Forest/Tree/Roles/JSONable.pm000644 000767 000767 00000001747 12254320225 021510 0ustar00stevanstevan000000 000000 package Forest::Tree::Roles::JSONable; use Moose::Role; our $VERSION = '0.10'; our $AUTHORITY = 'cpan:STEVAN'; requires 'as_json'; no Moose::Role; 1; __END__ =pod =head1 NAME Forest::Tree::Roles::JSONable - An abstract role for providing JSON serialization =head1 DESCRIPTION This is just an abstract role for trees capable of JSON serialization. =head1 REQUIRED METHODS =over 4 =item B Return a JSON string of the invocant. Takes C<%options> parameter to specify the way the tree is to be dumped. =back =head1 BUGS All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. =head1 AUTHOR Stevan Little Estevan.little@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2008-2014 Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Forest-0.10/lib/Forest/Tree/Roles/LoadWithMetaData.pm000644 000767 000767 00000002612 12254320225 023217 0ustar00stevanstevan000000 000000 package Forest::Tree::Roles::LoadWithMetaData; use Moose::Role; our $VERSION = '0.10'; our $AUTHORITY = 'cpan:STEVAN'; has 'metadata' => ( is => 'rw', isa => 'HashRef', default => sub { {} }, ); has 'metadata_key' => ( is => 'rw', isa => 'Str', default => sub { 'uid' }, ); around 'create_new_subtree' => sub { my $next = shift; my $self = shift; my $tree = $self->$next(@_); ($tree->does('Forest::Tree::Roles::MetaData')) || confess "Your subtrees must do the MetaData role"; my $key = $self->metadata_key; if (my $metadata = $self->metadata->{ $tree->$key() }) { $tree->metadata($metadata); } return $tree; }; no Moose::Role; 1; __END__ =pod =head1 NAME Forest::Tree::Roles::LoadWithMetaData - A Moosey solution to this problem =head1 SYNOPSIS use Forest::Tree::Roles::LoadWithMetaData; =head1 DESCRIPTION =head1 METHODS =over 4 =item B<> =back =head1 BUGS All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. =head1 AUTHOR Stevan Little Estevan.little@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2008-2014 Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Forest-0.10/lib/Forest/Tree/Roles/MetaData.pm000644 000767 000767 00000003504 12254320225 021564 0ustar00stevanstevan000000 000000 package Forest::Tree::Roles::MetaData; use Moose::Role; our $VERSION = '0.10'; our $AUTHORITY = 'cpan:STEVAN'; has 'metadata' => ( is => 'rw', isa => 'HashRef', default => sub { {} }, ); sub get_metadata_for { my ($self, $key) = @_; return $self->metadata->{$key}; } sub fetch_metadata_for { my ($self, $key) = @_; my $current = $self; do { if ($current->does(__PACKAGE__)) { my $meta = $current->metadata; return $meta->{$key} if exists $meta->{$key}; } $current = $current->parent; } until $current->is_root; if ($current->does(__PACKAGE__)) { my $meta = $current->metadata; return $meta->{$key} if exists $meta->{$key}; } return; } no Moose::Role; 1; __END__ =pod =head1 NAME Forest::Tree::Roles::MetaData - A role mixin to support tree node metadata =head1 DESCRIPTION This role mixin adds support for each tree node to have arbitrary metadata stored in a HASHref. The metadata is inherited in the tree as well, so a child will inherit the parents metadata. This is really useful, at least for me it is :) =head1 ATTRIBUTES =over 4 =item I =back =head1 METHODS =over 4 =item B This will first check locally, if it doesn't fund anything then will climb back to the root looking. =back =head1 BUGS All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. =head1 AUTHOR Stevan Little Estevan.little@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2008-2014 Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Forest-0.10/lib/Forest/Tree/Reader/SimpleTextFile.pm000644 000767 000767 00000005055 12254320225 023123 0ustar00stevanstevan000000 000000 package Forest::Tree::Reader::SimpleTextFile; use Moose; our $VERSION = '0.10'; our $AUTHORITY = 'cpan:STEVAN'; use Forest::Tree::Builder::SimpleTextFile; with qw(Forest::Tree::Reader Forest::Tree::Constructor); # see new_subtree_callback below # FIXME these are for compat... remove them? has 'tab_width' => ( is => 'rw', isa => 'Int', default => 4 ); has 'parser' => ( is => 'rw', isa => 'CodeRef', lazy => 1, builder => 'build_parser', ); sub build_parser { return sub { my ($self, $line) = @_; my ($indent, $node) = ($line =~ /^(\s*)(.*)$/); my $depth = ((length $indent) / $self->tab_width); return ($depth, $node); } } sub parse_line { $_[0]->parser->(@_) } # compat endscreate_new_subtree(@_);}, sub read { my ($self, $fh) = @_; my $builder = Forest::Tree::Builder::SimpleTextFile->new( tree_class => ref( $self->tree ), tab_width => $self->tab_width, parser => $self->parser, fh => $fh, # since it's possible to subclass reader and implement this method, we # include Forest::Tree::Constructor into this class as well, and make # the builder use that definition (which under normal circumstances # will be the same, Forest::Tree::Constructor::create_new_subtree) new_subtree_callback => sub { my ( $builder, @args ) = @_; $self->create_new_subtree(@args); }, ); $self->tree->add_child($_) for @{ $builder->subtrees }; } __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =pod =head1 NAME Forest::Tree::Reader::SimpleTextFile - A reader for Forest::Tree heirarchies =head1 DESCRIPTION B. You should use L instead. This reads simple F<.tree> files, which are basically the tree represented as a tabbed heirarchy. =head1 ATTRIBUTES =over 4 =item I =back =head1 METHODS =over 4 =item B =item B =item B =back =head1 BUGS All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. =head1 AUTHOR Stevan Little Estevan.little@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2008-2014 Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Forest-0.10/lib/Forest/Tree/Loader/SimpleUIDLoader.pm000644 000767 000767 00000004026 12254320225 023150 0ustar00stevanstevan000000 000000 package Forest::Tree::Loader::SimpleUIDLoader; use Moose; our $VERSION = '0.10'; our $AUTHORITY = 'cpan:STEVAN'; with 'Forest::Tree::Loader'; has 'row_parser' => ( is => 'ro', isa => 'CodeRef', default => sub { sub { my $row = shift; $row->{node}, $row->{uid}, $row->{parent_uid} } }, ); sub load { my ($self, $table) = @_; my $root = $self->tree; my $row_parser = $self->row_parser; my %index; foreach my $row (@$table) { my ($node, $uid, undef) = $row_parser->($row); # NOTE: uids MUST be true values ... if ($uid) { my $t = $self->create_new_subtree( node => $node, uid => $uid, ); $index{ $uid } = $t; } } my @orphans; foreach my $row (@$table) { my (undef, $uid, $parent_uid) = $row_parser->($row); # NOTE: uids MUST be true values ... if ($uid) { my $tree = $index{ $uid }; if (my $parent = $index{ $parent_uid }) { $parent->add_child($tree); } else { push @orphans => $tree; } } } if (@orphans) { $root->add_children(@orphans); } else { $root->add_child( $index{ (sort keys %index)[0] } ); } $root; } __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =pod =head1 NAME Forest::Tree::Loader::SimpleUIDLoader - Loads a Forest::Tree heirarchy using UIDs =head1 DESCRIPTION =head1 METHODS =over 4 =item B<> =back =head1 BUGS All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. =head1 AUTHOR Stevan Little Estevan.little@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2008-2014 Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Forest-0.10/lib/Forest/Tree/Indexer/SimpleUIDIndexer.pm000644 000767 000767 00000002557 12254320225 023537 0ustar00stevanstevan000000 000000 package Forest::Tree::Indexer::SimpleUIDIndexer; use Moose; our $VERSION = '0.10'; our $AUTHORITY = 'cpan:STEVAN'; with 'Forest::Tree::Indexer'; sub build_index { my $self = shift; my $root = $self->get_root; my $index = $self->index; (!exists $index->{$root->uid}) || confess "Tree root has already been indexed, you must clear it before re-indexing"; $index->{$root->uid} = $root; $root->traverse(sub { my $t = shift; (!exists $index->{$t->uid}) || confess "Duplicate tree id (" . $t->uid . ") found"; $index->{$t->uid} = $t; }); }; __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =pod =head1 NAME Forest::Tree::Indexer::SimpleUIDIndexer - Indexes a Forest::Tree heiarchy by it's UID =head1 DESCRIPTION This creates an index of a Forest::Tree heiarchy using the UID as the key. =head1 METHODS =over 4 =item B =back =head1 BUGS All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. =head1 AUTHOR Stevan Little Estevan.little@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2008-2014 Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Forest-0.10/lib/Forest/Tree/Builder/Callback.pm000644 000767 000767 00000002060 12254320225 022076 0ustar00stevanstevan000000 000000 package Forest::Tree::Builder::Callback; use Moose::Role; our $VERSION = '0.10'; our $AUTHORITY = 'cpan:STEVAN'; with 'Forest::Tree::Builder' => { -excludes => [qw(create_new_subtree)] }; has new_subtree_callback => ( isa => "CodeRef|Str", is => "ro", required => 1, default => "Forest::Tree::Constructor::create_new_subtree", ); sub create_new_subtree { my ( $self, @args ) = @_; my $method = $self->new_subtree_callback; $self->$method(@args); } no Moose::Role; 1; __END__ =pod =head1 NAME Forest::Tree::Builder::Callback - A Forest tree builder with a callback for subtree construction =head1 DESCRIPTION TODO =head1 BUGS All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. =head1 AUTHOR Yuval Kogman =head1 COPYRIGHT AND LICENSE Copyright 2008-2014 Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cutForest-0.10/lib/Forest/Tree/Builder/SimpleTextFile.pm000644 000767 000120 00000006460 12254320225 023057 0ustar00stevanadmin000000 000000 package Forest::Tree::Builder::SimpleTextFile; use Moose; our $VERSION = '0.10'; our $AUTHORITY = 'cpan:STEVAN'; no warnings 'recursion'; with qw(Forest::Tree::Builder::Callback); # for compatibility with overriding create_new_subtree, otherwise invisible has fh => ( isa => "FileHandle", is => "ro", required => 1, ); has 'tab_width' => ( is => 'rw', isa => 'Int', default => 4 ); has 'parser' => ( is => 'rw', isa => 'CodeRef', lazy => 1, builder => 'build_parser', ); sub build_parser { return sub { my ($self, $line) = @_; my ($indent, $node) = ($line =~ /^(\s*)(.*)$/); my $depth = ((length $indent) / $self->tab_width); return ($depth, $node); } } sub parse_line { $_[0]->parser->(@_) } sub _build_subtrees { my $self = shift; my $cur_children = []; my @stack; my $fh = $self->fh; while ( defined(my $line = <$fh>) ) { chomp($line); next if !$line || $line =~ /^#/; my ($depth, $node, @rest) = $self->parse_line($line); if ( $depth > @stack ) { if ( $depth = @stack + 1 ) { push @stack, $cur_children; $cur_children = $cur_children->[-1]{children} = []; } else { die "Parse Error : the difference between the depth ($depth) and " . "the tree depth (" . scalar(@stack) . ") is too much (" . ($depth - @stack) . ") at line:\n'$line'"; } } elsif ( $depth < @stack ) { while ( $depth < @stack ) { foreach my $node ( @$cur_children ) { $node = $self->create_new_subtree(%$node); } $cur_children = pop @stack; } } push @$cur_children, { node => $node, @rest }; } while ( @stack ) { $_ = $self->create_new_subtree(%$_) for @$cur_children; $cur_children = pop @stack; } return [ map { $self->create_new_subtree(%$_) } @$cur_children ]; } __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =head1 NAME Forest::Tree::Builder::SimpleTextFile - Parse trees from indented ASCII files =head1 SYNOPSIS use Path::Class; my $file = file($path); my $builder = Forest::Tree::Builder::SimpleTextFile->new( fh => $file->openr, ); my $tree = $builder->tree; =head1 DESCRIPTION This module replaces L with a declarative api instead of an imperative one. =head1 ATTRIBUTES =over 4 =item fh The filehandle to read from. Required. =item parser A coderef that parses a single line from C and returns the node depth and its value. Defaults to space indented text. See also L. =item tab_width The indentation level for the default parser. Defaults to 4, which means that four spaces equate to one level of nesting. =back =head1 BUGS All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. =head1 AUTHOR Yuval Kogman =head1 COPYRIGHT AND LICENSE Copyright 2008-2014 Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Forest-0.10/inc/Module/000755 000767 000120 00000000000 12254320621 015316 5ustar00stevanadmin000000 000000 Forest-0.10/inc/Module/Install/000755 000767 000120 00000000000 12254320621 016724 5ustar00stevanadmin000000 000000 Forest-0.10/inc/Module/Install.pm000644 000767 000120 00000030135 12254320603 017264 0ustar00stevanadmin000000 000000 #line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.06'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. Forest-0.10/inc/Module/Install/Base.pm000644 000767 000120 00000002147 12254320603 020140 0ustar00stevanadmin000000 000000 #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 Forest-0.10/inc/Module/Install/Can.pm000644 000767 000120 00000006157 12254320603 017774 0ustar00stevanadmin000000 000000 #line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 236 Forest-0.10/inc/Module/Install/Fetch.pm000644 000767 000120 00000004627 12254320603 020324 0ustar00stevanadmin000000 000000 #line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Forest-0.10/inc/Module/Install/Makefile.pm000644 000767 000120 00000027437 12254320603 021014 0ustar00stevanadmin000000 000000 #line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 Forest-0.10/inc/Module/Install/Metadata.pm000644 000767 000120 00000043277 12254320603 021017 0ustar00stevanadmin000000 000000 #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Forest-0.10/inc/Module/Install/Win32.pm000644 000767 000120 00000003403 12254320603 020164 0ustar00stevanadmin000000 000000 #line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; Forest-0.10/inc/Module/Install/WriteAll.pm000644 000767 000120 00000002376 12254320603 021015 0ustar00stevanadmin000000 000000 #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1;