Tree-RB-0.500005/000755 000765 000024 00000000000 12453234204 013252 5ustar00arunstaff000000 000000 Tree-RB-0.500005/.cvsignore000644 000765 000024 00000000150 12453004030 015236 0ustar00arunstaff000000 000000 blib* Makefile Makefile.old Build _build* pm_to_blib* *.tar.gz .lwpcookies Tree-RB-* cover_db Tree-RB-0.500005/Changes000644 000765 000024 00000003001 12453234074 014544 0ustar00arunstaff000000 000000 Revision history for Tree-RB 0.500005 07 January 2014 Changed version format to not be a dev release. 0.500_005 07 January 2014 Added nth() method. Fixed issue tracker link. 0.500_004 15 September 2013 Documentation fixes: http://rt.cpan.org/Public/Bug/Display.html?id=56453 http://rt.cpan.org/Public/Bug/Display.html?id=86636 0.500_003 22 November 2009 Fixed http://rt.cpan.org/Public/Bug/Display.html?id=49078 0.500_002 15 July 2009 Fixed http://rt.cpan.org/Public/Bug/Display.html?id=47894 Moved to Module::Install 0.500_001 10 June 2009 Changes in distribution packaging to include repository URL No code changes. 0.5 15 November 2008 16:43 Allow false values to be stored (thanks to Anton Petrusevich for pointing out the problem). Skip test of tied hash SCALAR method if we're not running at least 5.8.3 0.4 13 August 2008 10:15 No code changes, just fixed Build.PL to include dependency on enum. Happy birthday Jyothi! 0.3 09 August 2008 19:47 Tree iteration is now seekable. Hash iteration is now seekable and reversible. Use enum as it leads to more natural syntax than constant. 0.2 02 August 2008 12:57 Changes to work with older Perls: * 'use vars' instead of 'our' * Manually pull in &Exporter::import * Added a comment crediting java.util.TreeMap for balancing helper functions. 0.1 01 January 2008 20:05 Initial release. Tree-RB-0.500005/inc/000755 000765 000024 00000000000 12453234204 014023 5ustar00arunstaff000000 000000 Tree-RB-0.500005/lib/000755 000765 000024 00000000000 12453234204 014020 5ustar00arunstaff000000 000000 Tree-RB-0.500005/Makefile.PL000644 000765 000024 00000000463 12453004030 015217 0ustar00arunstaff000000 000000 use strict; use warnings; use inc::Module::Install; # Define metadata repository 'http://github.com/arunbear/perl5-red-black-tree'; name 'Tree-RB'; all_from 'lib/Tree/RB.pm'; # Specific dependencies requires 'enum' => 0; test_requires 'Test::More' => '0.42'; WriteAll; Tree-RB-0.500005/MANIFEST000644 000765 000024 00000000713 12453004030 014374 0ustar00arunstaff000000 000000 .cvsignore 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/Tree/RB.pm lib/Tree/RB/Node.pm lib/Tree/RB/Node/_Constants.pm Makefile.PL MANIFEST META.yml README t/00.load.t t/01.node.t t/01.node_constants.t t/02.tree.t t/03.delete.t t/04.lookup.t t/06.tie.t t/07.rt_47894.t Tree-RB-0.500005/META.yml000644 000765 000024 00000001237 12453234174 014534 0ustar00arunstaff000000 000000 --- abstract: "Perl implementation of the Red/Black tree, a type of balanced binary search tree. \r" author: - "Arun Prasad C<< >>\r" build_requires: ExtUtils::MakeMaker: 6.36 Test::More: '0.42' configure_requires: ExtUtils::MakeMaker: 6.36 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.14' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Tree-RB no_index: directory: - inc - t requires: enum: 0 resources: license: http://dev.perl.org/licenses/ repository: http://github.com/arunbear/perl5-red-black-tree version: '0.500005' Tree-RB-0.500005/README000644 000765 000024 00000004502 12453004030 014123 0ustar00arunstaff000000 000000 Tree-RB version 0.1 NAME Tree::RB - Perl implementation of the Red/Black tree, a type of balanced binary search tree. SYNOPSIS use Tree::RB; my $tree = Tree::RB->new; $tree->put('France' => 'Paris'); $tree->put('England' => 'London'); $tree->put('Hungary' => 'Budapest'); $tree->put('Ireland' => 'Dublin'); $tree->put('Egypt' => 'Cairo'); $tree->put('Germany' => 'Berlin'); $tree->put('Alaska' => 'Anchorage'); # D'oh! $tree->delete('Alaska'); print $tree->get('Ireland'); # 'Dublin' print $tree->min->key; # 'Egypt' print $tree->max->key; # 'Ireland' print $tree->size; # 6 # print items, ordered by key my $it = $tree->iter; while(my $node = $it->next) { sprintf "key = %s, value = %s\n", $node->key, $node->val; } # print items in reverse order $it = $tree->rev_iter; while(my $node = $it->next) { sprintf "key = %s, value = %s\n", $node->key, $node->val; } # Hash interface tie my %capital, 'Tree::RB'; # or do this to store items in descending order tie my %capital, 'Tree::RB', sub { $_[1] cmp $_[0] }; $capital{'France'} = 'Paris'; $capital{'England'} = 'London'; $capital{'Hungary'} = 'Budapest'; $capital{'Ireland'} = 'Dublin'; $capital{'Egypt'} = 'Cairo'; $capital{'Germany'} = 'Berlin'; # print items in order while(my ($key, $val) = each %capital) { printf "key = $key, value = $val\n"; } DESCRIPTION This is a Perl implementation of the Red/Black tree, a type of balanced binary search tree. A tied hash interface is also provided to allow ordered hashes to be used. See the Wikipedia article at for more on Red/Black trees. INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install DEPENDENCIES None. COPYRIGHT AND LICENCE Copyright (C) 2007, Arun Prasad This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Tree-RB-0.500005/t/000755 000765 000024 00000000000 12453234204 013515 5ustar00arunstaff000000 000000 Tree-RB-0.500005/t/00.load.t000644 000765 000024 00000000207 12453004030 015026 0ustar00arunstaff000000 000000 use Test::More tests => 3; BEGIN { use_ok( 'Tree::RB' ); use_ok( 'Tree::RB::Node' ); use_ok( 'Tree::RB::Node::_Constants' ); } Tree-RB-0.500005/t/01.node.t000644 000765 000024 00000004600 12453004030 015036 0ustar00arunstaff000000 000000 use Test::More tests => 27; use strict; use warnings; use_ok( 'Tree::RB::Node' ); diag( "Testing Tree::RB::Node $Tree::RB::Node::VERSION" ); foreach my $m (qw[ new key val color parent left right min max successor predecessor ]) { can_ok('Tree::RB::Node', $m); } my $node = Tree::RB::Node->new('England' => 'London'); # [England: London] isa_ok( $node, 'Tree::RB::Node' ); is($node->key, 'England', 'key retrieved after new'); is($node->val, 'London', 'value retrieved after new'); $node->key('France'); # [France: London] is($node->key, 'France', 'key retrieved after set'); $node->val('Paris'); # [France: Paris] is($node->val, 'Paris', 'value retrieved after set'); $node->color(1); is($node->color, 1, 'color retrieved after set'); my $left_node = Tree::RB::Node->new('England' => 'London'); $left_node->parent($node); $node->left($left_node); # [France: Paris] # / # [England: London] is($node->left, $left_node, 'left retrieved after set'); my $right_node = Tree::RB::Node->new('Hungary' => 'Budapest'); $right_node->parent($node); $node->right($right_node); # [France: Paris] # / \ # [England: London] [Hungary: Budapest] is($node->right, $right_node, 'right retrieved after set'); my $parent_node = Tree::RB::Node->new('Ireland' => 'Dublin'); $parent_node->left($node); $node->parent($parent_node); # [Ireland: Dublin] # / # [France: Paris] # / \ # [England: London] [Hungary: Budapest] is($node->parent, $parent_node, 'parent retrieved after set'); is($parent_node->min->key, 'England', 'min'); is($node->max->key, 'Hungary', 'max'); is($right_node->successor->key, 'Ireland', 'successor'); is($parent_node->predecessor->key, 'Hungary', 'predecessor'); my $egypt = Tree::RB::Node->new('Egypt' => 'Cairo'); $egypt->parent($left_node); $left_node->right($egypt); # [Ireland: Dublin] # / # [France: Paris] # / \ # [England: London] [Hungary: Budapest] # \ # [Egypt: Cairo] is($parent_node->leaf->key, 'Egypt', 'leaf'); $parent_node->strip; is($parent_node->leaf->key, 'Ireland', 'strip'); Tree-RB-0.500005/t/01.node_constants.t000644 000765 000024 00000000502 12453004030 017127 0ustar00arunstaff000000 000000 use Test::More tests => 9; use_ok( 'Tree::RB::Node::_Constants' ); diag( "Testing Tree::RB::Node::_Constants $Tree::RB::Node::_Constants::VERSION" ); foreach my $m (qw[ _PARENT _LEFT _RIGHT _COLOR _KEY _VAL BLACK RED ]) { can_ok('Tree::RB::Node::_Constants', $m); }Tree-RB-0.500005/t/02.tree.t000644 000765 000024 00000006325 12453004030 015057 0ustar00arunstaff000000 000000 use Test::More tests => 37; use strict; use warnings; use Data::Dumper; use_ok( 'Tree::RB' ); diag( "Testing Tree::RB $Tree::RB::VERSION" ); foreach my $m (qw[ new put iter rev_iter size ]) { can_ok('Tree::RB', $m); } my $tree = Tree::RB->new; isa_ok($tree, 'Tree::RB'); ok($tree->size == 0, 'New tree has size zero'); $tree->put('France' => 'Paris'); $tree->put('England' => 'London'); $tree->put('Hungary' => 'Budapest'); $tree->put('Ireland' => 'Dublin'); $tree->put('Egypt' => 'Cairo'); $tree->put('Germany' => 'Berlin'); ok($tree->size == 6, 'size check after inserts'); is($tree->min->key, 'Egypt', 'min'); is($tree->max->key, 'Ireland', 'max'); # Iterator tests my $it; $it = $tree->iter; isa_ok($it, 'Tree::RB::Iterator'); can_ok($it, 'next'); my @iter_tests = ( sub { my $node = $_[0]->next; ok($node->key eq 'Egypt' && $node->val eq 'Cairo', 'iterator check'); }, sub { my $node = $_[0]->next; ok($node->key eq 'England' && $node->val eq 'London', 'iterator check'); }, sub { my $node = $_[0]->next; ok($node->key eq 'France' && $node->val eq 'Paris', 'iterator check'); }, sub { my $node = $_[0]->next; ok($node->key eq 'Germany' && $node->val eq 'Berlin', 'iterator check'); }, sub { my $node = $_[0]->next; ok($node->key eq 'Hungary' && $node->val eq 'Budapest', 'iterator check'); }, sub { my $node = $_[0]->next; ok($node->key eq 'Ireland' && $node->val eq 'Dublin', 'iterator check'); }, sub { my $node = $_[0]->next; ok(!defined $node, 'iterator check - no more items'); }, ); foreach my $t (@iter_tests) { $t->($it); } # Reverse iterator tests $it = $tree->rev_iter; isa_ok($it, 'Tree::RB::Iterator'); can_ok($it, 'next'); my @rev_iter_tests = (reverse(@iter_tests[0 .. $#iter_tests-1]), $iter_tests[-1]); =pod Longer way to reverse my @rev_iter_tests = @iter_tests; @rev_iter_tests = (pop @rev_iter_tests, @rev_iter_tests); @rev_iter_tests = reverse @rev_iter_tests; =cut foreach my $t (@rev_iter_tests) { $t->($it); } # seeking my $node; $it = $tree->iter('France'); $node = $it->next; is($node->key, 'France', 'seek check, key exists'); $it = $tree->iter('Iceland'); $node = $it->next; is($node->key, 'Ireland', 'seek check, key does not exist but is lt max key'); $it = $tree->iter('Timbuktu'); $node = $it->next; ok(!defined $node, 'seek check, non existant key gt all keys') or diag(Dumper($node)); # seeking in reverse $it = $tree->rev_iter('Hungary'); $node = $it->next; is($node->key, 'Hungary', 'reverse seek check, key exists'); $node = $it->next; is($node->key, 'Germany', 'reverse seek check, next key lt this one'); $it = $tree->rev_iter('Finland'); $node = $it->next; is($node->key, 'England', 'reverse seek check, key does not exist but is gt min key'); $it = $tree->rev_iter('Albania'); $node = $it->next; ok(!defined $node, 'reverse seek check, non existant key lt all keys'); $tree->put('Timbuktu' => ''); is($tree->get('Timbuktu'), '', 'False values can be stored'); __END__ Tree-RB-0.500005/t/03.delete.t000644 000765 000024 00000004330 12453004030 015355 0ustar00arunstaff000000 000000 use Test::More tests => 13; use strict; use warnings; use Tree::RB; diag( "Testing deletion in Tree::RB $Tree::RB::VERSION" ); my $tree = Tree::RB->new; $tree->put('England' => 'London'); my $size = $tree->size; $tree->delete('England'); ok($size - $tree->size == 1, 'size goes down by one on removing a node'); my ($val, $node) = $tree->lookup('England'); ok(! defined $node, 'lookup deleted node'); ok(! defined $val, q[lookup deleted node's value]); $tree->put('France' => 'Paris'); $tree->put('England' => 'London'); $tree->put('Hungary' => 'Budapest'); $tree->put('Ireland' => 'Dublin'); $tree->put('Egypt' => 'Cairo'); # | # # /--------------\ # | | # # /------\ /-------\ # | | | | # <*> <*> # /---\ /---\ # | | | | # <*> <*> <*> <*> is($tree->delete('Hungary')->key, 'Hungary', 'delete intermediate node'); $tree->put('Hungary' => 'Budapest'); is($tree->delete('England')->key, 'England', 'delete intermediate node'); $tree->put('England' => 'London'); $tree->delete('Egypt'); is($tree->min->key, 'England', q[new min after deleting current min]); is($tree->max->key, 'Ireland', q[max not changed after deleting current min]); # | # # /-------------\ # | | # # /---\ /-------\ # | | | | # <*> <*> <*> # /---\ # | | # <*> <*> $tree->delete('Ireland'); is($tree->max->key, 'Hungary', q[new max after deleting current max]); is($tree->min->key, 'England', q[min not changed after deleting current max]); # | # # /-----------\ # | | # # /---\ /---\ # | | | | # <*> <*> <*> <*> is($tree->delete('France')->key, 'France', 'delete node with two kids'); is($tree->root->key, 'Hungary', q[new root]); is($tree->max->key, 'Hungary', q[max not changed]); is($tree->min->key, 'England', q[min not changed]); Tree-RB-0.500005/t/04.lookup.t000644 000765 000024 00000004136 12453231504 015441 0ustar00arunstaff000000 000000 use Test::More tests => 18; use strict; use warnings; use Data::Dumper; use Tree::RB qw[LUEQUAL LUGTEQ LULTEQ LUGREAT LULESS LUNEXT LUPREV]; diag( "Testing lookup in Tree::RB $Tree::RB::VERSION" ); my $tree = Tree::RB->new; $tree->put('France' => 'Paris'); $tree->put('England' => 'London'); $tree->put('Hungary' => 'Budapest'); $tree->put('Ireland' => 'Dublin'); $tree->put('Egypt' => 'Cairo'); $tree->put('Germany' => 'Berlin'); # | # # /------------------\ # | | # # /------\ /-----------\ # | | | | # <*> # /---\ /---\ /---\ # | | | | | | # <*> <*> <*> <*> <*> <*> my $val; my $node; $val = $tree->lookup('Germany'); is($val, 'Berlin', 'lookup'); $val = $tree->lookup('Belgium', LUGTEQ); is($val, 'Cairo', 'lookup LUGTEQ: left'); $val = $tree->lookup('Finland', LUGTEQ); is($val, 'Paris', 'lookup LUGTEQ: right'); ($val, $node) = $tree->lookup('Russia', LUGTEQ); is_deeply($node, undef, 'lookup LUGTEQ: no gt node') or diag('got: '. Dumper($node)); is('Budapest', $tree->lookup('Hungary', LULTEQ), 'lookup LULTEQ: node exists'); ($val, $node) = $tree->lookup('Belgium', LULTEQ); is_deeply($node, undef, 'lookup LULTEQ: no lt node') or diag('got: '. Dumper($node)); is($tree->lookup('Jamaica', LULTEQ), 'Dublin', 'lookup LULTEQ: right'); is($tree->lookup('Iceland', LULTEQ), 'Budapest', 'lookup LULTEQ: left'); is($tree->lookup('Belgium', LUGREAT), 'Cairo', 'lookup LUGREAT: left'); is($tree->lookup('Finland', LUGREAT), 'Paris', 'lookup LUGREAT: right'); is $tree->nth(0)->key => 'Egypt', 'nth: 0'; is $tree->nth(1)->key => 'England', 'nth: 1'; is $tree->nth(4)->key => 'Hungary', 'nth: 4'; is $tree->nth(5)->key => 'Ireland', 'nth: 5'; is $tree->nth(-6)->key => 'Egypt', 'nth: -6'; is $tree->nth(-5)->key => 'England', 'nth: -5'; is $tree->nth(-2)->key => 'Hungary', 'nth: -2'; is $tree->nth(-1)->key => 'Ireland', 'nth: -1'; Tree-RB-0.500005/t/06.tie.t000644 000765 000024 00000007611 12453004030 014704 0ustar00arunstaff000000 000000 use Test::More tests => 37; use strict; use warnings; use Data::Dumper; use Tree::RB; diag( "Testing tied hash interface in Tree::RB $Tree::RB::VERSION" ); my %capital; my $tied = tie(%capital, 'Tree::RB'); isa_ok($tied, 'Tree::RB'); ok(keys %capital == 0, 'Empty hash - no keys'); ok(! exists $capital{'France'}, 'exists on empty hash'); $capital{'France'} = 'Paris'; ok(exists $capital{'France'}, 'exists after insert'); is($capital{'France'}, 'Paris', 'STORE and FETCH work'); my $deleted = delete $capital{'France'}; ok(keys %capital == 0, 'Size check after deleting sole element'); isa_ok($deleted, 'Tree::RB::Node'); ok($deleted->key eq 'France' && $deleted->val eq 'Paris', 'check deleted node'); setup(); ok(keys %capital == 6, 'Size check (keys) after inserts'); SKIP: { skip "tied hash SCALAR method not available in version $]", 1 if $] < 5.008_003; ok(scalar %capital == 6, 'Size check (scalar) after inserts'); } my @keys = qw/Egypt England France Germany Hungary Ireland/; is_deeply([keys %capital], \@keys, 'check keys list'); is_deeply([values %capital], [qw/Cairo London Paris Berlin Budapest Dublin/], 'check values list'); my ($key, $val); ($key, $val) = each %capital; ok($key eq 'Egypt' && $val eq 'Cairo', 'each check'); ($key, $val) = each %capital; ok($key eq 'England' && $val eq 'London', 'each check'); ($key, $val) = each %capital; ok($key eq 'France' && $val eq 'Paris', 'each check'); ($key, $val) = each %capital; ok($key eq 'Germany' && $val eq 'Berlin', 'each check'); ($key, $val) = each %capital; ok($key eq 'Hungary' && $val eq 'Budapest', 'each check'); ($key, $val) = each %capital; ok($key eq 'Ireland' && $val eq 'Dublin', 'each check'); ($key, $val) = each %capital; ok(!defined $key && !defined $val , 'each check - no more keys'); undef %capital; ok(keys %capital == 0, 'no keys after clearing hash'); ok(scalar %capital == 0, 'size zero after clearing hash'); untie %capital; ok(@$tied == 0, 'underlying array is empty after untie'); # Custom sorting $tied = tie(%capital, 'Tree::RB', sub { $_[1] cmp $_[0] }); isa_ok($tied, 'Tree::RB'); setup(); is_deeply([keys %capital], [reverse @keys], 'check keys list (reverse sort)'); untie %capital; # Seeking $tied = tie(%capital, 'Tree::RB'); setup(); can_ok('Tree::RB', 'hseek'); $tied->hseek('Egypt'); $key = each %capital; is($key, 'Egypt', 'hseek to min key'); $tied->hseek('Germany'); ($key, $val) = each %capital; is($key, 'Germany', 'hseek check key'); $key = each %capital; is($key, 'Hungary', 'hseek check sequence'); $tied->hseek('Japan'); ($key, $val) = each %capital; is_deeply([$key, $val], [undef, undef], 'hseek to key gt max key'); $tied->hseek('Iceland'); $key = each %capital; is($key, 'Ireland', 'hseek to non existent key lt max key'); $tied->hseek({-key=> 'Belgium'}); $key = each %capital; is($key, 'Egypt', 'hseek to key lt min key'); # Reverse Seeking $tied->hseek({-reverse=> 1}); $key = each %capital; is($key, 'Ireland', 'reverse hseek to max key'); $key = each %capital; is($key, 'Hungary', 'reverse hseek check sequence'); $tied->hseek('Germany', {-reverse=> 1}); $key = each %capital; is($key, 'Germany', 'reverse hseek to existing key'); $tied->hseek('Iceland', {-reverse=> 1}); $key = each %capital; is($key, 'Hungary', 'reverse hseek to non existing key gt min'); $tied->hseek('Belgium', {-reverse=> 1}); $key = each %capital; is_deeply($key, undef, 'reverse hseek to non existing key lt min'); $tied->hseek({-reverse=> 1, -key=> 'Panama'}); $key = each %capital; is($key, 'Ireland', 'reverse hseek to non existing key gt max'); ## Helper Functions sub setup { %capital = ( France => 'Paris', England => 'London', Hungary => 'Budapest', Ireland => 'Dublin', Egypt => 'Cairo', Germany => 'Berlin', ); } Tree-RB-0.500005/t/07.rt_47894.t000644 000765 000024 00000000432 12453004030 015322 0ustar00arunstaff000000 000000 use Test::More tests => 2; use strict; use warnings; use Tree::RB; my $tree = Tree::RB->new(); my $iter = $tree->iter(); my $iter_with_key = $tree->iter('somekey'); ok(!defined $iter->next, 'iterate empty tree'); ok(!defined $iter_with_key->next, 'iterate empty tree with key'); Tree-RB-0.500005/lib/Tree/000755 000765 000024 00000000000 12453234204 014717 5ustar00arunstaff000000 000000 Tree-RB-0.500005/lib/Tree/RB/000755 000765 000024 00000000000 12453234204 015222 5ustar00arunstaff000000 000000 Tree-RB-0.500005/lib/Tree/RB.pm000644 000765 000024 00000057621 12453234105 015573 0ustar00arunstaff000000 000000 package Tree::RB; use strict; use Carp; use Tree::RB::Node qw[set_color color_of parent_of left_of right_of]; use Tree::RB::Node::_Constants; use vars qw( $VERSION @EXPORT_OK ); $VERSION = '0.500005'; $VERSION = eval $VERSION; require Exporter; *import = \&Exporter::import; @EXPORT_OK = qw[LUEQUAL LUGTEQ LULTEQ LUGREAT LULESS LUNEXT LUPREV]; use enum qw{ LUEQUAL LUGTEQ LULTEQ LUGREAT LULESS LUNEXT LUPREV }; # object slots use enum qw{ ROOT CMP SIZE HASH_ITER HASH_SEEK_ARG }; # Node and hash Iteration sub _mk_iter { my $start_fn = shift || 'min'; my $next_fn = shift || 'successor'; return sub { my $self = shift; my $key = shift; my $node; my $iter = sub { if($node) { $node = $node->$next_fn; } else { if(defined $key) { # seek to $key (undef, $node) = $self->lookup( $key, $next_fn eq 'successor' ? LUGTEQ : LULTEQ ); } else { $node = $self->$start_fn; } } return $node; }; return bless($iter => 'Tree::RB::Iterator'); }; } *Tree::RB::Iterator::next = sub { $_[0]->() }; *iter = _mk_iter(qw/min successor/); *rev_iter = _mk_iter(qw/max predecessor/); sub hseek { my $self = shift; my $arg = shift; defined $arg or croak("Can't seek to an undefined key"); my %args; if(ref $arg eq 'HASH') { %args = %$arg; } else { $args{-key} = $arg; } if(@_ && exists $args{-key}) { my $arg = shift; if(ref $arg eq 'HASH') { %args = (%$arg, %args); } } if(! exists $args{-key}) { defined $args{'-reverse'} or croak("Expected option '-reverse' is undefined"); } $self->[HASH_SEEK_ARG] = \%args; if($self->[HASH_ITER]) { $self->_reset_hash_iter; } } sub _reset_hash_iter { my $self = shift; if($self->[HASH_SEEK_ARG]) { my $iter = ($self->[HASH_SEEK_ARG]{'-reverse'} ? 'rev_iter' : 'iter'); $self->[HASH_ITER] = $self->$iter($self->[HASH_SEEK_ARG]{'-key'}); } else { $self->[HASH_ITER] = $self->iter; } } sub FIRSTKEY { my $self = shift; $self->_reset_hash_iter; my $node = $self->[HASH_ITER]->next or return; return $node->[_KEY]; } sub NEXTKEY { my $self = shift; my $node = $self->[HASH_ITER]->next or return; return $node->[_KEY]; } sub new { my ($class, $cmp) = @_; my $obj = []; $obj->[SIZE] = 0; if($cmp) { ref $cmp eq 'CODE' or croak('Invalid arg: codref expected'); $obj->[CMP] = $cmp; } return bless $obj => $class; } *TIEHASH = \&new; sub DESTROY { $_[0]->[ROOT]->DESTROY if $_[0]->[ROOT] } sub CLEAR { my $self = shift; if($self->[ROOT]) { $self->[ROOT]->DESTROY; undef $self->[ROOT]; undef $self->[HASH_ITER]; $self->[SIZE] = 0; } } sub UNTIE { my $self = shift; $self->DESTROY; undef @$self; } sub resort { my $self = $_[0]; my $cmp = $_[1]; ref $cmp eq 'CODE' or croak sprintf(q[Arg of type coderef required; got %s], ref $cmp || 'undef'); my $new_tree = __PACKAGE__->new($cmp); $self->[ROOT]->strip(sub { $new_tree->put($_[0]) }); $new_tree->put(delete $self->[ROOT]); $_[0] = $new_tree; } sub root { $_[0]->[ROOT] } sub size { $_[0]->[SIZE] } *SCALAR = \&size; sub min { my $self = shift; return undef unless $self->[ROOT]; return $self->[ROOT]->min; } sub max { my $self = shift; return undef unless $self->[ROOT]; return $self->[ROOT]->max; } sub lookup { my $self = shift; my $key = shift; defined $key or croak("Can't use undefined value as key"); my $mode = shift || LUEQUAL; my $cmp = $self->[CMP]; my $y; my $x = $self->[ROOT] or return; my $next_child; while($x) { $y = $x; if($cmp ? $cmp->($key, $x->[_KEY]) == 0 : $key eq $x->[_KEY]) { # found it! if($mode == LUGREAT || $mode == LUNEXT) { $x = $x->successor; } elsif($mode == LULESS || $mode == LUPREV) { $x = $x->predecessor; } return wantarray ? ($x->[_VAL], $x) : $x->[_VAL]; } if($cmp ? $cmp->($key, $x->[_KEY]) < 0 : $key lt $x->[_KEY]) { $next_child = _LEFT; } else { $next_child = _RIGHT; } $x = $x->[$next_child]; } # Didn't find it :( if($mode == LUGTEQ || $mode == LUGREAT) { if($next_child == _LEFT) { return wantarray ? ($y->[_VAL], $y) : $y->[_VAL]; } else { my $next = $y->successor or return; return wantarray ? ($next->[_VAL], $next) : $next->[_VAL]; } } elsif($mode == LULTEQ || $mode == LULESS) { if($next_child == _RIGHT) { return wantarray ? ($y->[_VAL], $y) : $y->[_VAL]; } else { my $next = $y->predecessor or return; return wantarray ? ($next->[_VAL], $next) : $next->[_VAL]; } } return; } *FETCH = \&lookup; *get = \&lookup; sub nth { my ($self, $i) = @_; $i =~ /^-?\d+$/ or croak('Integer index expected'); if ($i < 0) { $i += $self->[SIZE]; } if ($i < 0 || $i >= $self->[SIZE]) { return; } my ($node, $next, $moves); if ($i > $self->[SIZE] / 2) { $node = $self->max; $next = 'predecessor'; $moves = $self->[SIZE] - $i - 1; } else { $node = $self->min; $next = 'successor'; $moves = $i; } my $count = 0; while ($count != $moves) { $node = $node->$next; ++$count; } return $node; } sub EXISTS { my $self = shift; my $key = shift; return defined $self->lookup($key); } sub put { my $self = shift; my $key_or_node = shift; defined $key_or_node or croak("Can't use undefined value as key or node"); my $val = shift; my $cmp = $self->[CMP]; my $z = (ref $key_or_node eq 'Tree::RB::Node') ? $key_or_node : Tree::RB::Node->new($key_or_node => $val); my $y; my $x = $self->[ROOT]; while($x) { $y = $x; # Handle case of inserting node with duplicate key. if($cmp ? $cmp->($z->[_KEY], $x->[_KEY]) == 0 : $z->[_KEY] eq $x->[_KEY]) { my $old_val = $x->[_VAL]; $x->[_VAL] = $z->[_VAL]; return $old_val; } if($cmp ? $cmp->($z->[_KEY], $x->[_KEY]) < 0 : $z->[_KEY] lt $x->[_KEY]) { $x = $x->[_LEFT]; } else { $x = $x->[_RIGHT]; } } # insert new node $z->[_PARENT] = $y; if(not defined $y) { $self->[ROOT] = $z; } else { if($cmp ? $cmp->($z->[_KEY], $y->[_KEY]) < 0 : $z->[_KEY] lt $y->[_KEY]) { $y->[_LEFT] = $z; } else { $y->[_RIGHT] = $z; } } $self->_fix_after_insertion($z); $self->[SIZE]++; } *STORE = \&put; sub _fix_after_insertion { my $self = shift; my $x = shift or croak('Missing arg: node'); $x->[_COLOR] = RED; while($x != $self->[ROOT] && $x->[_PARENT][_COLOR] == RED) { my ($child, $rotate1, $rotate2); if(($x->[_PARENT] || 0) == ($x->[_PARENT][_PARENT][_LEFT] || 0)) { ($child, $rotate1, $rotate2) = (_RIGHT, '_left_rotate', '_right_rotate'); } else { ($child, $rotate1, $rotate2) = (_LEFT, '_right_rotate', '_left_rotate'); } my $y = $x->[_PARENT][_PARENT][$child]; if($y && $y->[_COLOR] == RED) { $x->[_PARENT][_COLOR] = BLACK; $y->[_COLOR] = BLACK; $x->[_PARENT][_PARENT][_COLOR] = RED; $x = $x->[_PARENT][_PARENT]; } else { if($x == ($x->[_PARENT][$child] || 0)) { $x = $x->[_PARENT]; $self->$rotate1($x); } $x->[_PARENT][_COLOR] = BLACK; $x->[_PARENT][_PARENT][_COLOR] = RED; $self->$rotate2($x->[_PARENT][_PARENT]); } } $self->[ROOT][_COLOR] = BLACK; } sub delete { my ($self, $key_or_node) = @_; defined $key_or_node or croak("Can't use undefined value as key or node"); my $z = (ref $key_or_node eq 'Tree::RB::Node') ? $key_or_node : ($self->lookup($key_or_node))[1]; return unless $z; my $y; if($z->[_LEFT] && $z->[_RIGHT]) { # (Notes kindly provided by Christopher Gurnee) # When deleting a node 'z' which has two children from a binary search tree, the # typical algorithm is to delete the successor node 'y' instead (which is # guaranteed to have at most one child), and then to overwrite the key/values of # node 'z' (which is still in the tree) with the key/values (which we don't want # to lose) from the now-deleted successor node 'y'. # Since we need to return the deleted item, it's not good enough to overwrite the # key/values of node 'z' with those of node 'y'. Instead we swap them so we can # return the deleted values. $y = $z->successor; ($z->[_KEY], $y->[_KEY]) = ($y->[_KEY], $z->[_KEY]); ($z->[_VAL], $y->[_VAL]) = ($y->[_VAL], $z->[_VAL]); } else { $y = $z; } # splice out $y my $x = $y->[_LEFT] || $y->[_RIGHT]; if(defined $x) { $x->[_PARENT] = $y->[_PARENT]; if(! defined $y->[_PARENT]) { $self->[ROOT] = $x; } elsif($y == $y->[_PARENT][_LEFT]) { $y->[_PARENT][_LEFT] = $x; } else { $y->[_PARENT][_RIGHT] = $x; } # Null out links so they are OK to use by _fix_after_deletion delete @{$y}[_PARENT, _LEFT, _RIGHT]; # Fix replacement if($y->[_COLOR] == BLACK) { $self->_fix_after_deletion($x); } } elsif(! defined $y->[_PARENT]) { # return if we are the only node delete $self->[ROOT]; } else { # No children. Use self as phantom replacement and unlink if($y->[_COLOR] == BLACK) { $self->_fix_after_deletion($y); } if(defined $y->[_PARENT]) { no warnings 'uninitialized'; if($y == $y->[_PARENT][_LEFT]) { delete $y->[_PARENT][_LEFT]; } elsif($y == $y->[_PARENT][_RIGHT]) { delete $y->[_PARENT][_RIGHT]; } delete $y->[_PARENT]; } } $self->[SIZE]--; return $y; } *DELETE = \&delete; sub _fix_after_deletion { my $self = shift; my $x = shift or croak('Missing arg: node'); while($x != $self->[ROOT] && color_of($x) == BLACK) { my ($child1, $child2, $rotate1, $rotate2); no warnings 'uninitialized'; if($x == left_of(parent_of($x))) { ($child1, $child2, $rotate1, $rotate2) = (\&right_of, \&left_of, '_left_rotate', '_right_rotate'); } else { ($child1, $child2, $rotate1, $rotate2) = (\&left_of, \&right_of, '_right_rotate', '_left_rotate'); } use warnings; my $w = $child1->(parent_of($x)); if(color_of($w) == RED) { set_color($w, BLACK); set_color(parent_of($x), RED); $self->$rotate1(parent_of($x)); $w = right_of(parent_of($x)); } if(color_of($child2->($w)) == BLACK && color_of($child1->($w)) == BLACK) { set_color($w, RED); $x = parent_of($x); } else { if(color_of($child1->($w)) == BLACK) { set_color($child2->($w), BLACK); set_color($w, RED); $self->$rotate2($w); $w = $child1->(parent_of($x)); } set_color($w, color_of(parent_of($x))); set_color(parent_of($x), BLACK); set_color($child1->($w), BLACK); $self->$rotate1(parent_of($x)); $x = $self->[ROOT]; } } set_color($x, BLACK); } sub _left_rotate { my $self = shift; my $x = shift or croak('Missing arg: node'); my $y = $x->[_RIGHT] or return; $x->[_RIGHT] = $y->[_LEFT]; if($y->[_LEFT]) { $y->[_LEFT]->[_PARENT] = $x; } $y->[_PARENT] = $x->[_PARENT]; if(not defined $x->[_PARENT]) { $self->[ROOT] = $y; } else { $x == $x->[_PARENT]->[_LEFT] ? $x->[_PARENT]->[_LEFT] = $y : $x->[_PARENT]->[_RIGHT] = $y; } $y->[_LEFT] = $x; $x->[_PARENT] = $y; } sub _right_rotate { my $self = shift; my $y = shift or croak('Missing arg: node'); my $x = $y->[_LEFT] or return; $y->[_LEFT] = $x->[_RIGHT]; if($x->[_RIGHT]) { $x->[_RIGHT]->[_PARENT] = $y } $x->[_PARENT] = $y->[_PARENT]; if(not defined $y->[_PARENT]) { $self->[ROOT] = $x; } else { $y == $y->[_PARENT]->[_RIGHT] ? $y->[_PARENT]->[_RIGHT] = $x : $y->[_PARENT]->[_LEFT] = $x; } $x->[_RIGHT] = $y; $y->[_PARENT] = $x; } 1; # Magic true value required at end of module __END__ =head1 NAME Tree::RB - Perl implementation of the Red/Black tree, a type of balanced binary search tree. =head1 SYNOPSIS use Tree::RB; my $tree = Tree::RB->new; $tree->put('France' => 'Paris'); $tree->put('England' => 'London'); $tree->put('Hungary' => 'Budapest'); $tree->put('Ireland' => 'Dublin'); $tree->put('Egypt' => 'Cairo'); $tree->put('Germany' => 'Berlin'); $tree->put('Alaska' => 'Anchorage'); # D'oh! Alaska isn't a Country $tree->delete('Alaska'); print scalar $tree->get('Ireland'); # 'Dublin' print $tree->size; # 6 print $tree->min->key; # 'Egypt' print $tree->max->key; # 'Ireland' print $tree->nth(0)->key; # 'Egypt' print $tree->nth(-1)->key; # 'Ireland' # print items, ordered by key my $it = $tree->iter; while(my $node = $it->next) { printf "key = %s, value = %s\n", $node->key, $node->val; } # print items in reverse order $it = $tree->rev_iter; while(my $node = $it->next) { printf "key = %s, value = %s\n", $node->key, $node->val; } # Hash interface tie my %capital, 'Tree::RB'; # or do this to store items in descending order tie my %capital, 'Tree::RB', sub { $_[1] cmp $_[0] }; $capital{'France'} = 'Paris'; $capital{'England'} = 'London'; $capital{'Hungary'} = 'Budapest'; $capital{'Ireland'} = 'Dublin'; $capital{'Egypt'} = 'Cairo'; $capital{'Germany'} = 'Berlin'; # print items in order while(my ($key, $val) = each %capital) { printf "key = $key, value = $val\n"; } =head1 DESCRIPTION This is a Perl implementation of the Red/Black tree, a type of balanced binary search tree. A tied hash interface is also provided to allow ordered hashes to be used. See the Wikipedia article at L for further information about Red/Black trees. =head1 INTERFACE =head2 new([CODEREF]) Creates and returns a new tree. If a reference to a subroutine is passed to new(), the subroutine will be used to override the tree's default lexical ordering and provide a user a defined ordering. This subroutine should be just like a comparator subroutine used with L, except that it doesn't do the $a, $b trick. For example, to get a case insensitive ordering my $tree = Tree::RB->new(sub { lc $_[0] cmp lc $_[1]}); $tree->put('Wall' => 'Larry'); $tree->put('Smith' => 'Agent'); $tree->put('mouse' => 'micky'); $tree->put('duck' => 'donald'); my $it = $tree->iter; while(my $node = $it->next) { printf "key = %s, value = %s\n", $node->key, $node->val; } =head2 resort(CODEREF) Changes the ordering of nodes within the tree. The new ordering is specified by a comparator subroutine which must be passed to resort(). See L for further information about the comparator. =head2 size() Returns the number of nodes in the tree. =head2 root() Returns the root node of the tree. This will either be undef if no nodes have been added to the tree, or a L object. See the L manual page for details on the Node object. =head2 min() Returns the node with the minimal key. =head2 max() Returns the node with the maximal key. =head2 nth(INDEX) Returns the node at the given (zero based) index, or undef if there is no node at that index. Negative indexes can be used, with -1 indicating the last node, -2 the penultimate node and so on. =head2 lookup(KEY, [MODE]) When called in scalar context, lookup(KEY) returns the value associated with KEY. When called in list context, lookup(KEY) returns a list whose first element is the value associated with KEY, and whose second element is the node containing the key/value. An optional MODE parameter can be passed to lookup() to influence which key is returned. The values of MODE are constants that are exported on demand by Tree::RB use Tree::RB qw[LUEQUAL LUGTEQ LULTEQ LUGREAT LULESS LUNEXT LUPREV]; =over =item LUEQUAL This is the default mode. Returns the node exactly matching the key, or C if not found. =item LUGTEQ Returns the node exactly matching the specified key, if this is not found then the next node that is greater than the specified key is returned. =item LULTEQ Returns the node exactly matching the specified key, if this is not found then the next node that is less than the specified key is returned. =item LUGREAT Returns the node that is just greater than the specified key - not equal to. This mode is similar to LUNEXT except that the specified key need not exist in the tree. =item LULESS Returns the node that is just less than the specified key - not equal to. This mode is similar to LUPREV except that the specified key need not exist in the tree. =item LUNEXT Looks for the key specified, if not found returns C. If the node is found returns the next node that is greater than the one found (or C if there is no next node). This can be used to step through the tree in order. =item LUPREV Looks for the key specified, if not found returns C. If the node is found returns the previous node that is less than the one found (or C if there is no previous node). This can be used to step through the tree in reverse order. =back =head2 get(KEY) get() is an alias for lookup(). =head2 iter([KEY]) Returns an iterator object that can be used to traverse the tree in order. The iterator object supports a 'next' method that returns the next node in the tree or undef if all of the nodes have been visited. See the synopsis for an example. If a key is supplied, the iterator returned will traverse the tree in order starting from the node with key greater than or equal to the specified key. $it = $tree->iter('France'); my $node = $it->next; print $node->key; # -> 'France' =head2 rev_iter([KEY]) Returns an iterator object that can be used to traverse the tree in reverse order. If a key is supplied, the iterator returned will traverse the tree in order starting from the node with key less than or equal to the specified key. $it = $tree->rev_iter('France'); my $node = $it->next; print $node->key; # -> 'France' $it = $tree->rev_iter('Finland'); my $node = $it->next; print $node->key; # -> 'England' =head2 hseek(KEY, [{-reverse => 1|0}]) For tied hashes, determines the next entry to be returned by each. tie my %capital, 'Tree::RB'; $capital{'France'} = 'Paris'; $capital{'England'} = 'London'; $capital{'Hungary'} = 'Budapest'; $capital{'Ireland'} = 'Dublin'; $capital{'Egypt'} = 'Cairo'; $capital{'Germany'} = 'Berlin'; tied(%capital)->hseek('Germany'); ($key, $val) = each %capital; print "$key, $val"; # -> Germany, Berlin The direction of iteration can be reversed by passing a hashref with key '-reverse' and value 1 to hseek after or instead of KEY, e.g. to iterate over the hash in reverse order: tied(%capital)->hseek({-reverse => 1}); $key = each %capital; print $key; # -> Ireland The following calls are equivalent tied(%capital)->hseek('Germany', {-reverse => 1}); tied(%capital)->hseek({-key => 'Germany', -reverse => 1}); =head2 put(KEY, VALUE) Adds a new node to the tree. The first argument is the key of the node, the second is its value. If a node with that key already exists, its value is replaced with the given value and the old value is returned. Otherwise, undef is returned. =head2 delete(KEY) If the tree has a node with the specified key, that node is deleted from the tree and returned, otherwise C is returned. =head1 DEPENDENCIES L =head1 INCOMPATIBILITIES None reported. =head1 BUGS AND LIMITATIONS Please report any bugs or feature requests via the GitHub web interface at L. =head1 AUTHOR Arun Prasad C<< >> Some documentation has been borrowed from Benjamin Holzman's L and Damian Ivereigh's libredblack (L). =head1 ACKNOWLEDGEMENTS Thanks for bug reports go to Anton Petrusevich, Wes Thompson, Petre Mierlutiu, Tomer Vromen and Christopher Gurnee. =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Arun Prasad C<< >>. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =head1 DISCLAIMER OF WARRANTY BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. Tree-RB-0.500005/lib/Tree/RB/Node/000755 000765 000024 00000000000 12453234204 016107 5ustar00arunstaff000000 000000 Tree-RB-0.500005/lib/Tree/RB/Node.pm000644 000765 000024 00000021400 12453004030 016432 0ustar00arunstaff000000 000000 package Tree::RB::Node; use strict; use Carp; use Tree::RB::Node::_Constants; use vars qw( $VERSION @EXPORT_OK ); require Exporter; *import = \&Exporter::import; @EXPORT_OK = qw[set_color color_of parent_of left_of right_of]; $VERSION = '0.2'; my %attribute = ( key => _KEY, val => _VAL, color => _COLOR, parent => _PARENT, left => _LEFT, right => _RIGHT, ); sub _accessor { my $index = shift; return sub { my $self = shift; if (@_) { $self->[$index] = shift; } return $self->[$index]; }; } while(my($at, $idx) = each %attribute) { no strict 'refs'; *$at = _accessor($idx); } sub new { my $class = shift; my $obj = []; if (@_) { $obj->[_KEY] = shift; $obj->[_VAL] = shift; } return bless $obj, $class; } sub min { my $self = shift; while ($self->[_LEFT]) { $self = $self->[_LEFT]; } return $self; } sub max { my $self = shift; while ($self->[_RIGHT]) { $self = $self->[_RIGHT]; } return $self; } sub leaf { my $self = shift; while (my $any_child = $self->[_LEFT] || $self->[_RIGHT]) { $self = $any_child; } return $self; } sub successor { my $self = shift; if ($self->[_RIGHT]) { return $self->[_RIGHT]->min; } my $parent = $self->[_PARENT]; while ($parent && $parent->[_RIGHT] && $self == $parent->[_RIGHT]) { $self = $parent; $parent = $parent->[_PARENT]; } return $parent; } sub predecessor { my $self = shift; if ($self->[_LEFT]) { return $self->[_LEFT]->max; } my $parent = $self->[_PARENT]; while ($parent && $parent->[_LEFT] && $self == $parent->[_LEFT]) { $self = $parent; $parent = $parent->[_PARENT]; } return $parent; } sub as_lol { my $self = shift; my $node = shift || $self; my $aref; push @$aref, $node->[_LEFT] ? $self->as_lol($node->[_LEFT]) : '*'; push @$aref, $node->[_RIGHT] ? $self->as_lol($node->[_RIGHT]) : '*'; my $color = ($node->[_COLOR] == RED ? 'R' : 'B'); no warnings 'uninitialized'; push @$aref, "$color:$node->[_KEY]"; return $aref; } sub strip { my $self = shift; my $callback = shift; my $x = $self; while($x) { my $leaf = $x->leaf; $x = $leaf->[_PARENT]; # detach $leaf from the (sub)tree no warnings "uninitialized"; if($leaf == $x->[_LEFT]) { undef $x->[_LEFT]; } else { undef $x->[_RIGHT]; } undef $leaf->[_PARENT]; if($callback) { $callback->($leaf); } if(!$x->[_LEFT] && !$x->[_RIGHT]) { $x = $x->[_PARENT]; } } } sub DESTROY { $_[0]->strip; } # Null aware accessors to assist with rebalancings during insertion and deletion # # A weird case of Java to the rescue! # These are inspired by http://www.javaresearch.org/source/jdk142/java/util/TreeMap.java.html # which was found via http://en.wikipedia.org/wiki/Red-black_tree#Implementations sub set_color { my ($node, $color) = @_; if($node) { $node->[_COLOR] = $color || BLACK; } } sub color_of { $_[0] ? $_[0]->[_COLOR] : BLACK; } sub parent_of { $_[0] ? $_[0]->[_PARENT] : undef; } sub left_of { $_[0] ? $_[0]->[_LEFT] : undef; } sub right_of { $_[0] ? $_[0]->[_RIGHT] : undef; } 1; # Magic true value required at end of module __END__ =head1 NAME Tree::RB::Node - A node class for implementing Red/Black trees =head1 VERSION This document describes Tree::RB::Node version 0.0.1 =head1 SYNOPSIS use Tree::RB; my $tree = Tree::RB->new; $tree->put('France' => 'Paris'); $tree->put('England' => 'London'); my $node = $tree->delete('France'); # $node is a Tree::RB::Node object print $node->key; # 'France' print $node->val; # 'Paris' =head1 DESCRIPTION A Tree::RB tree is made up of nodes that are objects of type Tree::RB::Node =head1 INTERFACE A Tree::RB::Node object supports the following methods: =head2 new() Creates and returns a new node. =head2 key([KEY]) Get/set the key of the node. This is what the nodes are sorted by in the tree. =head2 val([VALUE]) Get/set the value of the node. This can be any scalar. =head2 color([COLOR]) Get/set the color of the node. Valid colors are the constants RED and BLACK which are exported by Tree::RB::Node::_Constants =head2 parent([PARENT]) Get/set the parent of the node, which must be another Tree::RB::Node object. =head2 left([NODE]) Get/set the left child node of the node, which must be another Tree::RB::Node object. =head2 right([NODE]) Get/set the right child node of the node, which must be another Tree::RB::Node object. =head2 min() Returns the node with the minimal key starting from this node. =head2 max() Returns the node with the maximal key starting from this node. =head2 leaf() Returns the first leaf node found starting from this node, using a depth first, left to right search. =head2 successor() Returns the node with the smallest key larger than this node's key, or C if it is the node with the maximal key. =head2 predecessor() Returns the node with the greatest key smaller than this node's key, or C if it is the node with the minimal key. =head2 as_lol([NODE]) Returns a list of lists representing the tree whose root is either NODE if NODE is specified, or this node otherwise. This could be used for printing a tree, as the following snippet shows (this assumes that Tree::DAG_Node is also installed) use strict; use Tree::DAG_Node; use Tree::RB; my $t = Tree::RB->new; foreach (qw/the rain in spain falls mainly in the plains/) { $t->put($_, "${_} val"); } my $tree = Tree::DAG_Node->lol_to_tree( $t->root->as_lol ); $, = "\n"; print @{ $tree->draw_ascii_tree }; This will print | /-------------------\ | | /-----------\ /------\ | | | | <*> /---\ /------\ /---\ | | | | | | <*> <*> <*> <*> <*> /---\ | | <*> <*> =head2 strip([$callback]) Strips off all nodes under this node. If a callback is specified, it will be called once for each node that is detached, with the detached node as its sole argument. =head1 DEPENDENCIES None. =head1 INCOMPATIBILITIES None reported. =head1 BUGS AND LIMITATIONS Please report any bugs or feature requests to C, or through the web interface at L. =head1 AUTHOR Arun Prasad C<< >> Some documentation has been borrowed from Benjamin Holzman's L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Arun Prasad C<< >>. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =head1 DISCLAIMER OF WARRANTY BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. Tree-RB-0.500005/lib/Tree/RB/Node/_Constants.pm000644 000765 000024 00000005433 12453004030 020555 0ustar00arunstaff000000 000000 package Tree::RB::Node::_Constants; use strict; use Carp; use vars qw( $VERSION @EXPORT ); $VERSION = '0.3'; require Exporter; *import = \&Exporter::import; my @Node_slots; my @Node_colors; BEGIN { @Node_slots = qw(PARENT LEFT RIGHT COLOR KEY VAL); @Node_colors = qw(RED BLACK); } @EXPORT = (@Node_colors, map {"_$_"} @Node_slots); use enum @Node_colors; use enum @Node_slots; # enum doesn't allow symbols to start with "_", but we want them foreach my $s (@Node_slots) { no strict 'refs'; *{"_$s"} = \&$s; delete $Tree::RB::Node::_Constants::{$s}; } 1; # Magic true value required at end of module __END__ =head1 NAME Tree::RB::Node::_Constants - Tree::RB guts =head1 VERSION This document describes Tree::RB::Node::_Constants version 0.1 =head1 SYNOPSIS (internal use only) =head1 DESCRIPTION This module exists solely to provide contants for use by Tree::RB and Tree::RB::Node. =head1 DEPENDENCIES L =head1 INCOMPATIBILITIES None reported. =head1 BUGS AND LIMITATIONS Please report any bugs or feature requests to C, or through the web interface at L. =head1 AUTHOR Arun Prasad C<< >> =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Arun Prasad C<< >>. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =head1 DISCLAIMER OF WARRANTY BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. Tree-RB-0.500005/inc/Module/000755 000765 000024 00000000000 12453234204 015250 5ustar00arunstaff000000 000000 Tree-RB-0.500005/inc/Module/Install/000755 000765 000024 00000000000 12453234204 016656 5ustar00arunstaff000000 000000 Tree-RB-0.500005/inc/Module/Install.pm000644 000765 000024 00000030217 12453234173 017224 0ustar00arunstaff000000 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.006; 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.14'; # 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::getcwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::getcwd(); 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::getcwd()) 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 /\n/, $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]): $!"; binmode FH; 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]): $!"; binmode FH; 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]): $!"; binmode FH; 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]): $!"; binmode FH; 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. Tree-RB-0.500005/inc/Module/Install/Base.pm000644 000765 000024 00000002147 12453234174 020100 0ustar00arunstaff000000 000000 #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.14'; } # 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 Tree-RB-0.500005/inc/Module/Install/Can.pm000644 000765 000024 00000006157 12453234174 017734 0ustar00arunstaff000000 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.14'; @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 Tree-RB-0.500005/inc/Module/Install/Fetch.pm000644 000765 000024 00000004627 12453234174 020264 0ustar00arunstaff000000 000000 #line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.14'; @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; Tree-RB-0.500005/inc/Module/Install/Makefile.pm000644 000765 000024 00000027437 12453234174 020754 0ustar00arunstaff000000 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.14'; @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-separated 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 Tree-RB-0.500005/inc/Module/Install/Metadata.pm000644 000765 000024 00000043302 12453234174 020744 0ustar00arunstaff000000 000000 #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.14'; @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 hashes 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; Tree-RB-0.500005/inc/Module/Install/Win32.pm000644 000765 000024 00000003403 12453234174 020124 0ustar00arunstaff000000 000000 #line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.14'; @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; Tree-RB-0.500005/inc/Module/Install/WriteAll.pm000644 000765 000024 00000002376 12453234174 020755 0ustar00arunstaff000000 000000 #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.14'; @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;