File Coverage

blib/lib/Paranoid/Data/AVLTree.pm
Criterion Covered Total %
statement 325 406 80.0
branch 70 116 60.3
condition 13 26 50.0
subroutine 37 43 86.0
pod 10 10 100.0
total 455 601 75.7


line stmt bran cond sub pod time code
1             # Paranoid::Data::AVLTree -- AVL-Balanced Tree Class
2             #
3             # $Id: lib/Paranoid/Data/AVLTree.pm, 2.08 2020/12/31 12:10:06 acorliss Exp $
4             #
5             # This software is free software. Similar to Perl, you can redistribute it
6             # and/or modify it under the terms of either:
7             #
8             # a) the GNU General Public License
9             # as published by the
10             # Free Software Foundation ; either version 1
11             # , or any later version
12             # , or
13             # b) the Artistic License 2.0
14             # ,
15             #
16             # subject to the following additional term: No trademark rights to
17             # "Paranoid" have been or are conveyed under any of the above licenses.
18             # However, "Paranoid" may be used fairly to describe this unmodified
19             # software, in good faith, but not as a trademark.
20             #
21             # (c) 2005 - 2020, Arthur Corliss (corliss@digitalmages.com)
22             # (tm) 2008 - 2020, Paranoid Inc. (www.paranoid.com)
23             #
24             #####################################################################
25              
26             #####################################################################
27             #
28             # Environment definitions
29             #
30             #####################################################################
31              
32             package Paranoid::Data::AVLTree;
33              
34 1     1   525 use 5.008;
  1         3  
35              
36 1     1   5 use strict;
  1         1  
  1         17  
37 1     1   4 use warnings;
  1         1  
  1         22  
38 1     1   4 use vars qw($VERSION);
  1         1  
  1         42  
39 1     1   5 use base qw(Exporter);
  1         2  
  1         61  
40 1     1   5 use Paranoid;
  1         2  
  1         35  
41 1     1   379 use Paranoid::Debug qw(:all);
  1         2  
  1         167  
42 1     1   437 use Paranoid::Data::AVLTree::AVLNode;
  1         3  
  1         38  
43 1     1   6 use Carp;
  1         2  
  1         78  
44              
45             ($VERSION) = ( q$Revision: 2.08 $ =~ /(\d+(?:\.\d+)+)/sm );
46              
47 1     1   6 use constant AVLROOT => 0;
  1         1  
  1         42  
48 1     1   4 use constant AVLKEYS => 1;
  1         2  
  1         3149  
49              
50             #####################################################################
51             #
52             # Module code follows
53             #
54             #####################################################################
55              
56             sub new {
57              
58             # Purpose: instantiates an AVLTree object
59             # Returns: Object reference if successful, undef otherwise
60             # Usage: $obj = Paranoid::Data::AVLTree->new();
61              
62 3     3 1 22 my ( $class, %args ) = splice @_;
63 3         6 my $self = [undef];
64              
65 3         9 pdebug( 'entering w/%s', PDLEVEL1, %args );
66 3         7 pIn();
67              
68 3         4 bless $self, $class;
69              
70 3         7 pOut();
71 3         5 pdebug( 'leaving w/rv: %s', PDLEVEL1, $self );
72              
73 3         28 return $self;
74             }
75              
76             sub count {
77              
78             # Purpose: Returns the number of nodes in the tree
79             # Returns: Integer
80             # Usage: $count = $obj->count;
81              
82 8     8 1 18 my $self = shift;
83              
84 8 100       27 return defined $$self[AVLROOT] ? $$self[AVLROOT]->count : 0;
85             }
86              
87             sub height {
88              
89             # Purpose: Returns the height of the tree based on the longest branch
90             # Returns: Integer
91             # Usage: $height = $obj->height;
92              
93 12     12 1 1629 my $self = shift;
94              
95 12 100       39 return defined $$self[AVLROOT] ? $$self[AVLROOT]->height : 0;
96             }
97              
98             sub _printKeys {
99              
100             # Purpose: Prints the key structure of a tree starting with the node
101             # passed, and includes all children
102             # Returns: String
103             # Usage: $output = _printKeys($root);
104              
105 0     0   0 my $i = shift;
106 0         0 my $node = shift;
107 0         0 my $side = shift;
108 0         0 my $h = $node->height;
109 0         0 my $b = $node->balance;
110 0         0 my $line = '';
111              
112 0 0       0 $line = ' ' x $i if $i;
113 0 0       0 $line .= defined $side ? "($side/$h/$b) " : "($h/$b) ";
114 0         0 $line .= $node->key;
115 0         0 $line .= "\n";
116              
117 0         0 $i++;
118 0 0       0 $line .= _printKeys( $i, $node->left, 'l' ) if defined $node->left;
119 0 0       0 $line .= _printKeys( $i, $node->right, 'r' ) if defined $node->right;
120              
121 0         0 return $line;
122             }
123              
124             sub dumpKeys {
125              
126             # Purpose: A wrapper method that calls _printKeys() with the root node
127             # stored in the object
128             # Returns: String
129             # Usage: $obj->dumpKeys;
130              
131 0     0 1 0 my $self = shift;
132 0         0 my $line = '';
133              
134 0 0       0 $line = _printKeys( 1, $$self[AVLROOT] ) if defined $$self[AVLROOT];
135 0         0 warn "Key Dump:\n$line";
136              
137 0         0 return 1;
138             }
139              
140             sub _keys {
141              
142             # Purpose: Returns an array containing all the keys in tree starting
143             # with the passed node
144             # Returns: List of Strings
145             # Usage: @keys = _keys($rootNode);
146              
147 18     18   21 my $node = shift;
148 18         29 my @stack = $node->key;
149              
150 18 100       28 push @stack, _keys( $node->left ) if defined $node->left;
151 18 100       27 push @stack, _keys( $node->right ) if defined $node->right;
152              
153 18         34 return @stack;
154             }
155              
156             sub nodeKeys {
157              
158             # Purpose: A wrapper method that calles _keys with the root node
159             # stored in the object
160             # Returns: List of Strings
161             # Usage: @keys = $obj->nodeKeys;
162              
163 5     5 1 6 my $self = shift;
164 5         6 my @k;
165              
166 5 100       15 @k = _keys( $$self[AVLROOT] ) if defined $$self[AVLROOT];
167              
168 5         12 return @k;
169             }
170              
171             sub _findNode {
172              
173             # Purpose: Checks for the existence of a matching node in the tree
174             # and updates the passed references for the path to where
175             # the node would be positioned, as well as the node, if
176             # there is one.
177             # Returns: Boolean
178             # Usage: $rv = $obj->_findNode($key, $node, @path);
179              
180 112     112   153 my $self = shift;
181 112         122 my $key = shift;
182 112         115 my $nref = shift;
183 112         111 my $pref = shift;
184 112         133 my $root = $$self[AVLROOT];
185 112         117 my $rv = 0;
186 112         118 my ( @path, $node );
187              
188 112         205 pdebug( 'entering w/(%s)(%s)(%s)', PDLEVEL4, $key, $nref, $pref );
189 112         202 pIn();
190              
191 112         144 $$nref = undef;
192 112         137 @$pref = ();
193 112 100       187 if ( defined $root ) {
194 108         117 $node = $root;
195 108         161 while ( defined $node ) {
196 314 100       498 if ( $node->key eq $key ) {
197 92         104 $rv = 1;
198 92         100 $$nref = $node;
199 92         162 pdebug( 'node found: %s', PDLEVEL4, $$nref );
200 92         125 last;
201             } else {
202 222         285 push @path, $node;
203 222 100       317 $node = $key gt $node->key ? $node->right : $node->left;
204             }
205             }
206 108         156 @$pref = @path;
207 108         171 pdebug( 'path to node position: %s', PDLEVEL4, @$pref );
208             }
209              
210 112         230 pOut();
211 112         228 pdebug( 'leaving w/rv: %s', PDLEVEL4, $rv );
212              
213 112         205 return $rv;
214             }
215              
216             sub nodeExists {
217              
218             # Purpose: Checks for the existence of a matching node
219             # Returns: Boolean
220             # Usage: $rv = $obj->nodeExists($key):
221              
222 6     6 1 9 my $self = shift;
223 6         8 my $key = shift;
224 6         6 my $rv = 0;
225 6         16 my ( @path, $node );
226              
227 6         16 pdebug( 'entering w/%s', PDLEVEL3, $key );
228 6         16 pIn();
229              
230 6 50       11 if ( defined $key ) {
231 6         19 $self->_findNode( $key, \$node, \@path );
232 6         8 $rv = defined $node;
233             }
234              
235 6         12 pOut();
236 6         13 pdebug( 'leaving w/rv: %s', PDLEVEL3, $rv );
237              
238 6         18 return $self->_findNode( $key, \$node, \@path );
239             }
240              
241             sub fetchVal {
242              
243             # Purpose: Returns the associated value for the key, if it's present
244             # Returns: Scalar
245             # Usage: $val = obj->fetchVal($key);
246              
247 2     2 1 4 my $self = shift;
248 2         3 my $key = shift;
249 2         4 my ( @path, $node, $val );
250              
251 2         5 pdebug( 'entering w/%s', PDLEVEL3, $key );
252 2         5 pIn();
253              
254 2 50       4 if ( defined $key ) {
255 2         6 $self->_findNode( $key, \$node, \@path );
256 2         23 pdebug( 'node is %s', PDLEVEL4, $node );
257 2 50       17 $val = $node->val if defined $node;
258             }
259              
260 2         5 pOut();
261 2 50       7 pdebug( 'leaving w/rv: %s bytes',
262             PDLEVEL3, defined $val
263             ? length $val
264             : 0 );
265              
266 2         7 return $val;
267             }
268              
269             sub _addNode {
270              
271             # Purpose: Adds or updates a node for the key/value passed
272             # Returns: Boolean
273             # Usage: $rv = $obj->_addNode($key, $value);
274              
275 20     20   25 my $self = shift;
276 20         23 my $key = shift;
277 20         22 my $val = shift;
278 20         24 my $root = $$self[AVLROOT];
279 20         39 my $rv = 1;
280 20         26 my ( @path, $nn, $node, $parent );
281              
282 20         40 pdebug( 'entering w/ %s => %s', PDLEVEL3, $key, $val );
283 20         38 pIn();
284              
285             # Validation check
286 20         48 $nn = Paranoid::Data::AVLTree::AVLNode->new( $key, $val );
287              
288 20 50       31 if ( defined $nn ) {
289 20 100       37 if ( defined $root ) {
290 16 50       32 if ( $self->_findNode( $key, \$node, \@path ) ) {
291 0         0 $node->setVal($val);
292 0         0 pdebug( 'updating existing node', PDLEVEL4 );
293             } else {
294              
295             # Attach the new node
296 16         38 foreach (@path) {
297 42 100       71 if ( $key gt $_->key ) {
298 28         44 $_->incrRHeight;
299             } else {
300 14         24 $_->incrLHeight;
301             }
302             }
303 16 100       43 if ( $key gt $path[-1]->key ) {
304 14         21 $path[-1]->setRight($nn);
305             } else {
306 2         5 $path[-1]->setLeft($nn);
307             }
308 16         23 pdebug( 'added node at the end of the branch', PDLEVEL4 );
309              
310             }
311              
312             } else {
313 4         8 $$self[AVLROOT] = $nn;
314 4         7 pdebug( 'adding node as the tree root: %s',
315             PDLEVEL4, $$self[AVLROOT] );
316             }
317              
318             } else {
319 0         0 $rv = 0;
320 0         0 pdebug( 'invalid key submitted: %s', PDLEVEL1, $key );
321             }
322              
323 20         46 pOut();
324 20         39 pdebug( 'leaving w/rv: %s', PDLEVEL3, $rv );
325              
326 20         36 return $rv;
327             }
328              
329             sub _updtRootRef {
330              
331             # Purpose: Updates the parent link matching the original ref
332             # with the new ref. Link can be on either side of
333             # the branch, or could be root of the tree, entirely.
334             # Returns: Boolean
335             # Usage: $rv = $obj->_updtRootRef($root, $oldref, $newref);
336              
337 18     18   23 my $self = shift;
338 18         17 my $root = shift;
339 18         28 my $oref = shift;
340 18         20 my $nref = shift;
341 18         20 my $rv = 1;
342              
343 18 100       31 if ( defined $root ) {
344              
345             # Update the parent link (could be on either side) to the child
346 10 100 100     18 if ( defined $root->left and $root->left == $oref ) {
    50 33        
347 6         13 pdebug( 'updating link on the root\'s right side', PDLEVEL4 );
348 6         11 $root->setLeft($nref);
349             } elsif ( defined $root->right and $root->right == $oref ) {
350 4         8 pdebug( 'updating link on the root\'s left side', PDLEVEL4 );
351 4         7 $root->setRight($nref);
352             } else {
353 0         0 pdebug( 'ERROR: old ref not linked to root!', PDLEVEL1 );
354 0         0 $rv = 0;
355             }
356              
357             } else {
358              
359             # No parent means we're rotating the root
360 8         16 pdebug( 'updating root node link', PDLEVEL4 );
361 8         13 $$self[AVLROOT] = $nref;
362             }
363              
364 18         25 return $rv;
365             }
366              
367             sub _rrr {
368              
369             # Purpose: Performs a single rotate right
370             # Returns: Boolean
371             # Usage: $rv = $self->_rrr($root, $node);
372              
373 5     5   6 my $self = shift;
374 5         5 my $root = shift;
375 5         6 my $x = shift;
376 5         9 my $z = $x->left;
377 5         7 my $rv;
378              
379 5         9 pdebug( 'entering w/(%s)(%s)', PDLEVEL4, $root, $x );
380 5         9 pIn();
381              
382             # Update root node as a prerequisite to continuing
383 5 50 33     23 $rv = defined $x and defined $z and $self->_updtRootRef( $root, $x, $z );
384              
385             # Update x & z refs
386 5 50       8 if ($rv) {
387 5         10 $x->setLeft( $z->right );
388 5         12 $z->setRight($x);
389              
390             # Update heights
391 5         10 $x->updtHeights;
392 5         8 $z->updtHeights;
393 5 100       6 if ( defined $root ) {
394 2         4 $root->updtHeights;
395             } else {
396 3         14 $$self[AVLROOT]->updtHeights;
397             }
398             }
399              
400 5         11 pOut();
401 5         11 pdebug( 'leaving w/rv: %s', PDLEVEL4, $rv );
402              
403 5         9 return $rv;
404             }
405              
406             sub _rll {
407              
408             # Purpose: Performs a single rotate left
409             # Returns: Boolean
410             # Usage: $rv = $self->_rll($root, $node);
411              
412 8     8   9 my $self = shift;
413 8         8 my $root = shift;
414 8         8 my $x = shift;
415 8         13 my $z = $x->right;
416 8         9 my $rv;
417              
418 8         17 pdebug( 'entering w/(%s)(%s)', PDLEVEL4, $root, $x );
419 8         13 pIn();
420              
421             # Update root node as a prerequisite to continuing
422 8 50 33     50 $rv = defined $x and defined $z and $self->_updtRootRef( $root, $x, $z );
423              
424             # Update x & z refs
425 8 50       12 if ($rv) {
426 8         15 $x->setRight( $z->left );
427 8         16 $z->setLeft($x);
428              
429             # Update heights
430 8         17 $x->updtHeights;
431 8         16 $z->updtHeights;
432 8 100       11 if ( defined $root ) {
433 4         8 $root->updtHeights;
434             } else {
435 4         9 $$self[AVLROOT]->updtHeights;
436             }
437             }
438              
439 8         15 pOut();
440 8         15 pdebug( 'leaving w/rv: %s', PDLEVEL4, $rv );
441              
442 8         16 return $rv;
443             }
444              
445             sub _rrl {
446              
447             # Purpose: Performs a double rotation of right-left
448             # Returns: Boolean
449             # Usage: $rv = $self->_rrl($root, $node);
450              
451 0     0   0 my $self = shift;
452 0         0 my $root = shift;
453 0         0 my $x = shift;
454 0         0 my $z = $x->right;
455 0         0 my $y = $z->left;
456 0         0 my $rv = 0;
457              
458 0         0 pdebug( 'entering w/(%s)(%s)', PDLEVEL4, $root, $x );
459 0         0 pIn();
460              
461 0         0 $rv = $self->_rrr( $x, $z );
462 0 0       0 if ($rv) {
463 0         0 $z = $x->right;
464 0 0       0 if ( $z == $y ) {
465 0         0 $rv = $self->_rll( $root, $x );
466             } else {
467 0         0 pdebug( 'double rotation incorrect results on first rotation',
468             PDLEVEL1 );
469             }
470             } else {
471 0         0 pdebug( 'double rotation failed on first rotation', PDLEVEL1 );
472             }
473              
474 0         0 pOut();
475 0         0 pdebug( 'leaving w/rv: %s', PDLEVEL4, $rv );
476              
477 0         0 return $rv;
478             }
479              
480             sub _rlr {
481              
482             # Purpose: Performs a double rotation of left-right
483             # Returns: Boolean
484             # Usage: $rv = $self->_rlr($root, $node);
485              
486 0     0   0 my $self = shift;
487 0         0 my $root = shift;
488 0         0 my $x = shift;
489 0         0 my $z = $x->left;
490 0         0 my $y = $z->right;
491 0         0 my $rv = 0;
492              
493 0         0 pdebug( 'entering w/(%s)(%s)', PDLEVEL4, $root, $x );
494 0         0 pIn();
495              
496 0         0 $rv = $self->_rll( $x, $z );
497 0 0       0 if ($rv) {
498 0         0 $z = $x->left;
499 0 0       0 if ( $z == $y ) {
500 0         0 $rv = $self->_rrr( $root, $x );
501             } else {
502 0         0 pdebug( 'double rotation incorrect results on first rotation',
503             PDLEVEL1 );
504             }
505             } else {
506 0         0 pdebug( 'double rotation failed on first rotation', PDLEVEL1 );
507             }
508              
509 0         0 pOut();
510 0         0 pdebug( 'leaving w/rv: %s', PDLEVEL4, $rv );
511              
512 0         0 return $rv;
513             }
514              
515             sub _rotate {
516              
517             # Purpose: Performs the appropriate rotation for the specified node under
518             # the specified root. This includes not only what direction to
519             # rotate, but whether to perform a single or double rotation.
520             # Returns: Boolean
521             # Usage: $rv = $obj->_rotate($root, $node);
522              
523 13     13   17 my $self = shift;
524 13         23 my $root = shift;
525 13         15 my $x = shift;
526 13         14 my $rv = 1;
527              
528 13         26 pdebug( 'entering w/(%s)(%s)', PDLEVEL4, $root, $x );
529 13         28 pIn();
530              
531 13 100       22 if ( $x->balance > 1 ) {
    50          
532              
533             # Rotate left
534 8 50       15 if ( $x->right->balance < 0 ) {
535              
536             # Perform a double rotation
537 0         0 $rv = $self->_rrl( $root, $x );
538              
539             } else {
540              
541             # Perform a single rotation
542 8         15 $rv = $self->_rll( $root, $x );
543             }
544              
545             } elsif ( $x->balance < -1 ) {
546              
547             # Rotate right
548 5 50       10 if ( $x->left->balance > 0 ) {
549              
550             # Perform a double rotation
551 0         0 $rv = $self->_rlr( $root, $x );
552              
553             } else {
554              
555             # Perform a single rotation
556 5         18 $rv = $self->_rrr( $root, $x );
557             }
558             }
559              
560 13         29 pOut();
561 13         22 pdebug( 'leaving w/rv: %s', PDLEVEL4, $rv );
562              
563 13         20 return $rv;
564             }
565              
566             sub _rebalance {
567              
568             # Purpose: Rebalances the tree for the branch extending to the specified
569             # node by performing rotations on all nodes that are unbalanced
570             # Returns: Boolean
571             # Usage: $rv = $obj->($node);
572              
573 25     25   37 my $self = shift;
574 25         26 my $node = shift;
575 25         37 my $key = $node->key;
576 25         33 my ( @path, $parent, $n );
577              
578 25         48 pdebug( 'entering w/%s', PDLEVEL4, $node );
579 25         49 pIn();
580              
581 25 50       41 if ( $self->_findNode( $key, \$node, \@path ) ) {
582              
583             # Start at the bottom of the chain
584 25         33 push @path, $node;
585 25         53 $key = $node->key;
586              
587             # Find number of nodes that are unbalanced
588 25         42 $n = scalar grep { abs( $_->balance ) > 1 } @path;
  76         101  
589 25         48 while ($n) {
590 13         26 pdebug( 'found %s node(s) in the branch that are unbalanced',
591             PDLEVEL4, $n );
592 13         15 $node = $parent = undef;
593              
594 13         25 foreach (@path) {
595 19         22 $node = $_;
596 19 100       40 if ( abs( $node->balance ) > 1 ) {
597 13         22 pdebug( 'key: %s balance: %s',
598             PDLEVEL4, $node->key, $node->balance );
599              
600             # Determine type of rotation and execute it
601 13         27 $self->_rotate( $parent, $node );
602 13         28 $self->_findNode( $key, \$node, \@path );
603 13         19 push @path, $node;
604 13         17 $n = scalar grep { abs( $_->balance ) > 1 } @path;
  38         57  
605 13         26 last;
606             } else {
607 6         8 $parent = $node;
608             }
609             }
610             }
611             }
612              
613 25         77 pOut();
614 25         52 pdebug( 'leaving w/rv: 1', PDLEVEL4 );
615              
616 25         55 return 1;
617             }
618              
619             sub addPair {
620              
621             # Purpose: Adds or updates a node for the key/value passed
622             # Returns: Boolean
623             # Usage: $rv = $obj->addPair($key, $value);
624              
625 20     20 1 37 my $self = shift;
626 20         25 my $key = shift;
627 20         21 my $val = shift;
628 20         28 my $rv = 1;
629 20         26 my ( @path, $node );
630              
631 20         37 pdebug( 'entering w/ %s => %s', PDLEVEL3, $key, $val );
632 20         41 pIn();
633              
634 20         35 $rv = $self->_addNode( $key, $val );
635 20 50       33 if ($rv) {
636 20         43 $self->_findNode( $key, \$node, \@path );
637 20         47 $rv = $self->_rebalance($node);
638             }
639              
640 20         31 pOut();
641 20         32 pdebug( 'leaving w/rv: %s', PDLEVEL3, $rv );
642              
643 20         52 return $rv;
644             }
645              
646             sub _splice {
647              
648             # Purpose: Splices off the requested node and reattaches any
649             # sub-branches, and returns a new target key useful
650             # for tracing for rebalancing purposes.
651             # Returns: String
652             # Usage: $key = $obj->_splice($root, $node);
653              
654 1     1   4 my $self = shift;
655 1         7 my $root = shift;
656 1         2 my $node = shift;
657 1         3 my ( $rv, $ln, $rn, $cn, @path, $height );
658              
659 1         3 pdebug( 'entering w/(%s)(%s)', PDLEVEL4, $root, $node );
660 1         14 pIn();
661              
662 1         7 $ln = $node->left;
663 1         3 $rn = $node->right;
664              
665 1 50 33     7 if ( defined $ln and defined $rn ) {
666              
667             # Attach the longer branch underneath the shorter branch
668 1 50       11 if ( $ln->height < $rn->height ) {
669              
670             # Right branch is longer
671             #
672             # Find a place to attach on the left branch
673 0         0 push @path, $ln;
674 0         0 $cn = $ln;
675 0         0 while ( defined $cn->right ) {
676 0         0 $cn = $cn->right;
677 0         0 push @path, $cn;
678             }
679 0         0 $cn->setRight($rn);
680              
681             # Update the height back up to the root of the left branch
682 0         0 $height = $cn->height;
683 0         0 foreach ( reverse @path ) {
684 0 0       0 if ( $_->rHeight < $height ) {
685 0         0 $_->addRHeight( $height - $_->rHeight );
686             }
687 0         0 $height++;
688             }
689              
690             # Now, attach the left branch to the root
691 0         0 $self->_updtRootRef( $root, $node, $ln );
692              
693             # Hand back the node key that we're going to seek to in the
694             # calling function
695 0         0 $rv = $rn->key;
696              
697             } else {
698              
699             # Left branch is longer
700             #
701             # Find a place to attach on the right branch
702 1         2 push @path, $rn;
703 1         2 $cn = $rn;
704 1         2 while ( defined $cn->left ) {
705 1         2 $cn = $cn->left;
706 1         2 push @path, $cn;
707             }
708 1         2 $cn->setLeft($ln);
709              
710             # Update the height back up to the root of the left branch
711 1         1 $height = $cn->height;
712 1         3 foreach ( reverse @path ) {
713 2 50       14 if ( $_->lHeight < $height ) {
714 2         4 $_->addLHeight( $height - $_->lHeight );
715             }
716 2         7 $height++;
717             }
718              
719             # Now, attach the left branch to the root
720 1         5 $self->_updtRootRef( $root, $node, $rn );
721              
722             # Hand back the node key that we're going to seek to in the
723             # calling function
724 1         2 $rv = $ln->key;
725              
726             }
727              
728             } else {
729 0         0 pdebug( 'this function shouldn\'t be called without two branches',
730             PDLEVEL4 );
731             }
732              
733 1         3 pOut();
734 1         7 pdebug( 'leaving w/rv: %s', PDLEVEL4, $rv );
735              
736 1         2 return $rv;
737             }
738              
739             sub delNode {
740              
741             # Purpose: Removes the specifed node
742             # Returns: Boolean
743             # Usage: $rv = $obj->delNode($key);
744              
745 5     5 1 9 my $self = shift;
746 5         8 my $key = shift;
747 5         6 my $rv = 0;
748 5         6 my ( $root, $node, @path, $height );
749              
750 5         31 pdebug( 'entering w/%s', PDLEVEL4, $key );
751 5         11 pIn();
752              
753 5 50       13 if ( $self->_findNode( $key, \$node, \@path ) ) {
754 5         9 $root = $path[-1];
755              
756             # Test for simplest deletion conditions
757 5 100       11 if ( scalar $node->children <= 1 ) {
758              
759             # Node for deletion only has one or zero children
760 4 50       6 $rv =
    50          
761             defined $node->left
762             ? $self->_updtRootRef( $root, $node, $node->left )
763             : defined $node->right
764             ? $self->_updtRootRef( $root, $node, $node->right )
765             : $self->_updtRootRef( $root, $node, undef );
766              
767             # Adjust heights
768 4         10 foreach ( reverse @path ) {
769 11 100       21 if ( $key lt $_->key ) {
770 2 50 33     6 $_->decrLHeight
771             if defined $_->left
772             and $_->left->height < $_->lHeight;
773             } else {
774 9 100 100     14 $_->decrRHeight
775             if defined $_->right
776             and $_->right->height < $_->rHeight;
777             }
778             }
779              
780             } else {
781              
782             # Splice the node out
783 1         12 $key = $self->_splice( $root, $node );
784              
785 1 50       4 if ( $self->_findNode( $key, \$node, \@path ) ) {
786 1         2 $rv = 1;
787 1         1 $root = $node;
788              
789             } else {
790 0         0 pdebug( 'something went horribly wrong', PDLEVEL1 );
791             }
792              
793             }
794              
795             # Rebalance
796 5 50       13 $root = $$self[AVLROOT] unless defined $root;
797 5 50 33     31 $rv = $self->_rebalance($root) if defined $root and $rv;
798             }
799              
800 5         13 pOut();
801 5         16 pdebug( 'leaving w/rv: %s', PDLEVEL4, $rv );
802              
803 5         39 return $rv;
804             }
805              
806             sub purgeNodes {
807              
808             # Purpose: Deletes the root reference, essentially purging the entire
809             # tree
810             # Returns: Boolean
811             # Usage: $rv = $obj->purgeNodes;
812              
813 2     2 1 4 my $self = shift;
814              
815 2         6 pdebug( 'entering', PDLEVEL4 );
816              
817 2         6 $$self[AVLROOT] = undef;
818              
819 2         5 pdebug( 'leaving w/rv: 1', PDLEVEL4 );
820              
821 2         5 return 1;
822             }
823              
824             sub TIEHASH {
825 1     1   4 return new Paranoid::Data::AVLTree;
826             }
827              
828             sub FETCH {
829 1     1   18 my $self = shift;
830 1         1 my $key = shift;
831 1         10 my $rv;
832              
833 1         3 return $self->fetchVal($key);
834             }
835              
836             sub STORE {
837 10     10   562 my $self = shift;
838 10         14 my $key = shift;
839 10         12 my $val = shift;
840              
841 10         17 return $self->addPair( $key, $val );
842             }
843              
844             sub EXISTS {
845 3     3   7 my $self = shift;
846 3         4 my $key = shift;
847              
848 3         7 return $self->nodeExists($key);
849             }
850              
851             sub DELETE {
852 1     1   2 my $self = shift;
853 1         2 my $key = shift;
854              
855 1         3 return $self->delNode($key);
856             }
857              
858             sub CLEAR {
859 1     1   5 my $self = shift;
860              
861 1         3 return $self->purgeNodes;
862             }
863              
864             sub FIRSTKEY {
865 5     5   968 my $self = shift;
866 5         12 my @k = $self->nodeKeys();
867 5         6 my ( $key, $node, @path, %rv );
868              
869 5 100       10 if (@k) {
870 3         6 $key = shift @k;
871 3         7 $self->_findNode( $key, \$node, \@path );
872 3         6 %rv = ( $node->key() => $node->val() );
873 3         7 $$self[AVLKEYS] = [@k];
874             }
875              
876 5         25 return each %rv;
877             }
878              
879             sub NEXTKEY {
880 18     18   25 my $self = shift;
881 18         34 my ( $key, $node, @path, %rv );
882              
883 18 100 50     31 if ( defined $$self[AVLKEYS] and scalar @{ $$self[AVLKEYS] } ) {
  18         41  
884 15         17 $key = shift @{ $$self[AVLKEYS] };
  15         24  
885 15         32 $self->_findNode( $key, \$node, \@path );
886 15         33 %rv = ( $node->key() => $node->val() );
887             }
888              
889 18         57 return each %rv;
890             }
891              
892             sub SCALAR {
893 0     0     my $self = shift;
894              
895 0           return $self->count;
896             }
897              
898             sub UNTIE {
899 0     0     return 1;
900             }
901              
902             1;
903              
904             __END__