File Coverage

blib/lib/Tree/RB/XS.pm
Criterion Covered Total %
statement 49 53 92.4
branch 26 32 81.2
condition 18 31 58.0
subroutine 13 15 86.6
pod 4 4 100.0
total 110 135 81.4


line stmt bran cond sub pod time code
1             package Tree::RB::XS;
2             $Tree::RB::XS::VERSION = '0.06';
3             # VERSION
4             # ABSTRACT: Red/Black Tree implemented in C, with similar API to Tree::RB
5              
6 10     10   1819526 use strict;
  10         75  
  10         232  
7 10     10   41 use warnings;
  10         14  
  10         185  
8 10     10   37 use Carp;
  10         13  
  10         588  
9             require XSLoader;
10             XSLoader::load('Tree::RB::XS', $Tree::RB::XS::VERSION);
11 10     10   53 use Exporter 'import';
  10         16  
  10         8610  
12             our @_key_types= qw( KEY_TYPE_ANY KEY_TYPE_INT KEY_TYPE_FLOAT KEY_TYPE_BSTR KEY_TYPE_USTR );
13             our @_cmp_enum= qw( CMP_PERL CMP_INT CMP_FLOAT CMP_MEMCMP CMP_UTF8 CMP_NUMSPLIT );
14             our @_lookup_modes= qw( GET_EQ GET_EQ_LAST GET_GT GET_LT GET_GE GET_LE GET_LE_LAST GET_NEXT GET_PREV
15             LUEQUAL LUGTEQ LULTEQ LUGREAT LULESS LUNEXT LUPREV );
16             our @EXPORT_OK= (@_key_types, @_cmp_enum, @_lookup_modes);
17             our %EXPORT_TAGS= (
18             key_type => \@_key_types,
19             cmp => \@_cmp_enum,
20             lookup => \@_lookup_modes,
21             get => \@_lookup_modes,
22             all => \@EXPORT_OK,
23             );
24              
25              
26             sub new {
27 45     45 1 3788904 my $class= shift;
28 45 50 33     268 my %options= @_ == 1 && ref $_[0] eq 'HASH'? %{$_[0]}
  0 50       0  
29             : @_ == 1? ( compare_fn => $_[0] )
30             : @_;
31 45         94 my $self= bless \%options, $class;
32 45         417 $self->_init_tree(delete $self->{key_type}, delete $self->{compare_fn});
33 45 100       128 $self->allow_duplicates(1) if delete $self->{allow_duplicates};
34 45 50       107 $self->compat_list_get(1) if delete $self->{compat_list_get};
35 45         106 $self;
36             }
37              
38              
39             *root= *root_node;
40             *min= *min_node;
41             *max= *max_node;
42             *nth= *nth_node;
43              
44              
45             sub iter {
46 118     118 1 3727 my ($self, $key_or_node, $mode)= @_;
47 118 50 66     198 $key_or_node= $self->get_node($key_or_node, @_ > 2? $mode : GET_GE())
    100          
48             if @_ > 1 && ref $key_or_node ne 'Tree::RB::XS::Node';
49 118   66     261 Tree::RB::XS::Iter->_new($key_or_node || $self, 1);
50             }
51              
52             sub rev_iter {
53 107     107 1 1555 my ($self, $key_or_node, $mode)= @_;
54 107 50 66     178 $key_or_node= $self->get_node($key_or_node, @_ > 2? $mode : GET_LE_LAST())
    100          
55             if @_ > 1 && ref $key_or_node ne 'Tree::RB::XS::Node';
56 107   66     216 Tree::RB::XS::Iter->_new($key_or_node || $self, -1);
57             }
58              
59              
60             *Tree::RB::XS::Node::min= *Tree::RB::XS::Node::left_leaf;
61             *Tree::RB::XS::Node::max= *Tree::RB::XS::Node::right_leaf;
62             *Tree::RB::XS::Node::successor= *Tree::RB::XS::Node::next;
63             *Tree::RB::XS::Node::predecessor= *Tree::RB::XS::Node::prev;
64              
65              
66             sub Tree::RB::XS::Node::strip {
67 1     1   16 my ($self, $cb)= @_;
68 1   33     9 my ($at, $next, $last)= (undef, $self->left_leaf || $self, $self->right_leaf || $self);
      33        
69 1         3 do {
70 3         7 $at= $next;
71 3         7 $next= $next->next;
72 3 100       6 if ($at != $self) {
73 2         5 $at->prune;
74 2 50       6 $cb->($at) if $cb;
75             }
76             } while ($at != $last);
77             }
78              
79             sub Tree::RB::XS::Node::as_lol {
80 3   33 3   28 my $self= $_[1] || $_[0];
81             [
82 3 100 50     38 $self->left? $self->left->as_lol : '*',
    100          
    100          
83             $self->right? $self->right->as_lol : '*',
84             ($self->color? 'R':'B').':'.($self->key||'')
85             ]
86             }
87              
88             sub Tree::RB::XS::Node::iter {
89 3     3   46 Tree::RB::XS::Iter->_new($_[0], 1);
90             }
91              
92             sub Tree::RB::XS::Node::rev_iter {
93 1     1   650 Tree::RB::XS::Iter->_new($_[0], -1);
94             }
95              
96              
97             # I can't figure out how to do the closure in XS yet
98             sub Tree::RB::XS::Iter::_new {
99 229     229   235 my $class= shift;
100 229         200 my ($self,$y);
101 229     0   532 $self= bless sub { Tree::XS::RB::Iter::next($y) }, $class;
  0         0  
102 229         449 Scalar::Util::weaken($y= $self);
103 229         1049 $self->_init(@_);
104             }
105             sub Tree::RB::XS::Iter::clone {
106 0     0   0 my $self= shift;
107 0         0 ref($self)->_new($self);
108             }
109              
110              
111             *TIEHASH= *new;
112             *STORE= *put;
113             *CLEAR= *clear;
114              
115             sub hseek {
116 3     3 1 14384 my ($self, $key, $opts)= @_;
117 3 100 100     15 if (@_ == 2 && ref $key eq 'HASH') {
118 1         2 $opts= $key;
119 1         2 $key= $opts->{'-key'};
120             }
121 3   100     14 my $reverse= $opts && $opts->{'-reverse'} || 0;
122 3 100       20 my $node= defined $key? $self->get_node($key, $reverse? GET_LE_LAST() : GET_GE()) : undef;
    100          
123 3         16 $self->_set_hashiter($node, $reverse);
124             }
125              
126              
127             *LUEQUAL= *GET_EQ;
128             *LUGTEQ= *GET_GE;
129             *LUGTLT= *GET_LE;
130             *LUGREAT= *GET_GT;
131             *LULESS= *GET_LT;
132             *LUPREV= *GET_PREV;
133             *LUNEXT= *GET_NEXT;
134              
135              
136             1;
137              
138             __END__