File Coverage

blib/lib/Tree/RB/Node.pm
Criterion Covered Total %
statement 82 91 90.1
branch 18 30 60.0
condition 17 23 73.9
subroutine 22 23 95.6
pod 8 13 61.5
total 147 180 81.6


line stmt bran cond sub pod time code
1             package Tree::RB::Node;
2            
3 7     7   618 use strict;
  7         8  
  7         263  
4 7     7   26 use Carp;
  7         9  
  7         356  
5 7     7   2914 use Tree::RB::Node::_Constants;
  7         15  
  7         569  
6 7     7   33 use vars qw( $VERSION @EXPORT_OK );
  7         8  
  7         1322  
7            
8             require Exporter;
9             *import = \&Exporter::import;
10             @EXPORT_OK = qw[set_color color_of parent_of left_of right_of];
11            
12             $VERSION = '0.2';
13            
14             my %attribute = (
15             key => _KEY,
16             val => _VAL,
17             color => _COLOR,
18             parent => _PARENT,
19             left => _LEFT,
20             right => _RIGHT,
21             );
22            
23             sub _accessor {
24 42     42   42 my $index = shift;
25             return sub {
26 76     76   551 my $self = shift;
27 76 100       140 if (@_) {
28 11         14 $self->[$index] = shift;
29             }
30 76         236 return $self->[$index];
31 42         218 };
32             }
33            
34             while(my($at, $idx) = each %attribute) {
35 7     7   35 no strict 'refs';
  7         14  
  7         2738  
36             *$at = _accessor($idx);
37             }
38            
39             sub new {
40 45     45 1 4983 my $class = shift;
41 45         55 my $obj = [];
42            
43 45 50       97 if (@_) {
44 45         66 $obj->[_KEY] = shift;
45 45         75 $obj->[_VAL] = shift;
46             }
47 45         118 return bless $obj, $class;
48             }
49            
50             sub min {
51 29     29 1 31 my $self = shift;
52 29         64 while ($self->[_LEFT]) {
53 32         63 $self = $self->[_LEFT];
54             }
55 29         56 return $self;
56             }
57            
58             sub max {
59 16     16 1 19 my $self = shift;
60 16         45 while ($self->[_RIGHT]) {
61 18         40 $self = $self->[_RIGHT];
62             }
63 16         38 return $self;
64             }
65            
66             sub leaf {
67 67     67 1 57 my $self = shift;
68 67   100     211 while (my $any_child = $self->[_LEFT] || $self->[_RIGHT]) {
69 40         126 $self = $any_child;
70             }
71 67         67 return $self;
72             }
73            
74             sub successor {
75 46     46 1 45 my $self = shift;
76 46 100       90 if ($self->[_RIGHT]) {
77 14         22 return $self->[_RIGHT]->min;
78             }
79 32         40 my $parent = $self->[_PARENT];
80 32   100     192 while ($parent && $parent->[_RIGHT] && $self == $parent->[_RIGHT]) {
      100        
81 20         23 $self = $parent;
82 20         94 $parent = $parent->[_PARENT];
83             }
84 32         69 return $parent;
85             }
86            
87             sub predecessor {
88 16     16 1 22 my $self = shift;
89 16 100       38 if ($self->[_LEFT]) {
90 5         11 return $self->[_LEFT]->max;
91             }
92 11         11 my $parent = $self->[_PARENT];
93 11   66     78 while ($parent && $parent->[_LEFT] && $self == $parent->[_LEFT]) {
      100        
94 9         10 $self = $parent;
95 9         35 $parent = $parent->[_PARENT];
96             }
97 11         39 return $parent;
98             }
99            
100             sub as_lol {
101 0     0 1 0 my $self = shift;
102 0   0     0 my $node = shift || $self;
103 0         0 my $aref;
104 0 0       0 push @$aref,
105             $node->[_LEFT]
106             ? $self->as_lol($node->[_LEFT])
107             : '*';
108 0 0       0 push @$aref,
109             $node->[_RIGHT]
110             ? $self->as_lol($node->[_RIGHT])
111             : '*';
112 0 0       0 my $color = ($node->[_COLOR] == RED ? 'R' : 'B');
113 7     7   36 no warnings 'uninitialized';
  7         8  
  7         776  
114 0         0 push @$aref, "$color:$node->[_KEY]";
115 0         0 return $aref;
116             }
117            
118             sub strip {
119 45     45 1 48 my $self = shift;
120 45         38 my $callback = shift;
121            
122 45         40 my $x = $self;
123 45         72 while($x) {
124 65         75 my $leaf = $x->leaf;
125 65         65 $x = $leaf->[_PARENT];
126            
127             # detach $leaf from the (sub)tree
128 7     7   34 no warnings "uninitialized";
  7         9  
  7         1757  
129 65 100       116 if($leaf == $x->[_LEFT]) {
130 14         19 undef $x->[_LEFT];
131             }
132             else {
133 51         57 undef $x->[_RIGHT];
134             }
135 65         57 undef $leaf->[_PARENT];
136 65 50       88 if($callback) {
137 0         0 $callback->($leaf);
138             }
139            
140 65 100 33     172 if(!$x->[_LEFT] && !$x->[_RIGHT]) {
141 56         271 $x = $x->[_PARENT];
142             }
143             }
144             }
145            
146 44     44   783 sub DESTROY { $_[0]->strip; }
147            
148             # Null aware accessors to assist with rebalancings during insertion and deletion
149             #
150             # A weird case of Java to the rescue!
151             # These are inspired by http://www.javaresearch.org/source/jdk142/java/util/TreeMap.java.html
152             # which was found via http://en.wikipedia.org/wiki/Red-black_tree#Implementations
153            
154             sub set_color {
155 6     6 0 8 my ($node, $color) = @_;
156 6 50       10 if($node) {
157 6   100     17 $node->[_COLOR] = $color || BLACK;
158             }
159             }
160            
161             sub color_of {
162 8 100   8 0 37 $_[0] ? $_[0]->[_COLOR] : BLACK;
163             }
164            
165             sub parent_of {
166 3 50   3 0 11 $_[0] ? $_[0]->[_PARENT] : undef;
167             }
168            
169             sub left_of {
170 3 50   3 0 8 $_[0] ? $_[0]->[_LEFT] : undef;
171             }
172            
173             sub right_of {
174 1 50   1 0 5 $_[0] ? $_[0]->[_RIGHT] : undef;
175             }
176            
177            
178             1; # Magic true value required at end of module
179             __END__