File Coverage

blib/lib/Net/IPAM/Tree/Private.pm
Criterion Covered Total %
statement 89 89 100.0
branch 32 32 100.0
condition 3 3 100.0
subroutine 12 12 100.0
pod n/a
total 136 136 100.0


line stmt bran cond sub pod time code
1             package Net::IPAM::Tree::Private;
2              
3 6     6   64 use 5.10.0;
  6         18  
4 6     6   28 use strict;
  6         8  
  6         124  
5 6     6   40 use warnings;
  6         19  
  6         166  
6 6     6   39 use utf8;
  6         10  
  6         31  
7 6     6   3261 use List::MoreUtils qw();
  6         73404  
  6         5153  
8              
9             =head1 NAME
10              
11             Net::IPAM::Tree::Private - private implementation for Net::IPAM::Tree
12              
13             =head1 SYNOPSIS
14              
15             This module is not useful standalone, it's just needed for Net::IPAM::Tree.
16             The implementation details are hidden by the public API in Net::IPAM::Tree.
17              
18             =head1 FUNCTIONS
19              
20             =head2 _buildIndexTree($tree, $parent, $child)
21              
22             Building the tree with just the array indices, the sorted items itself are not moved.
23             create the {parent}->[childs] map, rec-descent algo.
24              
25             =cut
26              
27             sub _build_index_tree {
28 48     48   68 my ( $t, $parent, $child ) = @_;
29              
30             # if parent has no childs yet, just append the child idx
31 48 100       99 if ( not defined $t->{_tree}{$parent} ) {
32 14         19 push @{ $t->{_tree}{$parent} }, $child;
  14         37  
33 14         43 return;
34             }
35              
36             # everything is sorted, just look for previous child for coverage
37              
38             # get prev child idx for this parent
39 34         44 my $prev = $t->{_tree}{$parent}[-1];
40              
41             # item is covered by previous child, it's an ancestor, not a sibling
42 34 100       70 if ( $t->{_items}[$prev]->contains( $t->{_items}[$child] ) ) {
43              
44             # rec-descent
45 14         275 _build_index_tree( $t, $prev, $child );
46 14         24 return;
47             }
48              
49             # not covered by previous child, append as sibling
50 20         350 push @{ $t->{_tree}{$parent} }, $child;
  20         34  
51              
52 20         33 return;
53             }
54              
55             ####
56             # _superset($block)
57             #
58             # returns the outermost containing block or undef
59             sub _superset {
60 8     8   11 my ( $t, $block ) = @_;
61              
62             # derefernce child idxs array
63 8         14 my $c_idxs = $t->{_tree}{_ROOT};
64              
65             # find first index where child->{block} >= block
66 8     15   59 my $idx = List::MoreUtils::lower_bound { $t->{_items}[$_]->cmp($block) } @$c_idxs;
  15         65  
67              
68             # returns -1 on undefined list
69 8 100       59 if ( $idx < 0 ) {
70 2         11 return;
71             }
72              
73             # test if found by exact match?
74             # search index may be at end, take care for index panics
75 6 100       29 if ( $idx < @$c_idxs ) {
76              
77             # deref for better reading and debugging
78 5         10 my $i = $c_idxs->[$idx];
79              
80 5 100       11 if ( $t->{_items}[$i]->cmp($block) == 0 ) {
81              
82             # the items on root level are disjunct, maybe overlapping, BUT NOT covering each other
83             # therefore we can return here, no element before can overlap this item
84              
85 1         13 return $t->{_items}[$i];
86             }
87             }
88              
89             # not equal and no item before can cover block
90 5 100       27 if ( $idx == 0 ) {
91 1         5 return;
92             }
93              
94             # remember match
95 4         6 my $match;
96              
97             # some items before idx may cover item, find the leftmost
98 4         14 for ( my $j = $idx - 1 ; $j >= 0 ; $j-- ) {
99              
100             # deref for better reading and debugging
101 5         6 my $i = $c_idxs->[$j];
102              
103 5 100       11 if ( $t->{_items}[$i]->contains($block) ) {
104              
105             # save match, but continue to find leftmost superset
106 2         39 $match = $t->{_items}[$i];
107 2         5 next;
108             }
109              
110             # remember: the items on root level are disjunct, maybe overlapping, BUT NOT covering each other
111             # premature stop condition without item coverage, last match was superset
112              
113 3         56 last;
114             }
115              
116 4         19 return $match;
117             }
118              
119             ####
120             # _lookup($block)
121             #
122             # Returns item in tree with longest-prefix-match for $block, returns undef if not found.
123             #
124             # thing is a Net::IPAM::Block or a subclass of them
125             #
126             # returns the lpm block
127             #
128             # rec-descent algo
129             sub _lookup {
130 14     14   22 my ( $t, $parent, $block ) = @_;
131              
132             # derefernce child idxs array
133 14         27 my $c_idxs = $t->{_tree}{$parent};
134              
135             # find first index where child->{block} >= block
136 14     22   67 my $idx = List::MoreUtils::lower_bound { $t->{_items}[$_]->cmp($block) } @$c_idxs;
  22         93  
137              
138             # found by exact match?
139             # search index may be -1 or at end, take care for index panics
140 14 100 100     105 if ( $idx >= 0 and $idx < @$c_idxs ) {
141              
142             # deref for better reading and debugging
143 7         12 my $i = $c_idxs->[$idx];
144              
145 7 100       14 if ( $t->{_items}[$i]->cmp($block) == 0 ) {
146 2         20 return $t->{_items}[$i];
147             }
148             }
149              
150             # look if child before idx contains block
151             # search index may be 0, take care for index panics
152 12 100       43 if ( $idx > 0 ) {
153              
154             # deref for better reading and debugging
155 7         13 my $i = $c_idxs->[ $idx - 1 ];
156              
157 7 100       15 if ( $t->{_items}[$i]->contains($block) ) {
158              
159             # rec-descent
160 3         60 return _lookup( $t, $i, $block );
161             }
162             }
163              
164             # return parent at this level, if root returns undef
165 9 100       83 if ( $parent eq '_ROOT' ) {
166 7         30 return;
167             }
168              
169 2         10 return $t->{_items}[$parent];
170             }
171              
172             # recdescent to string
173             sub _to_string {
174 23     23   47 my ( $t, $cb, $parent, $buf, $prefix ) = @_;
175              
176 23         39 my $c_idxs = $t->{_tree}{$parent};
177              
178             # STOP condition, no more childs
179 23 100       43 unless ( defined $c_idxs ) {
180 16         36 return $buf;
181             }
182              
183 7         11 my $len_c = @$c_idxs;
184              
185             # stop before last child
186 7         14 for my $i ( @{$c_idxs}[ 0 .. $len_c - 2 ] ) {
  7         17  
187 12         28 $buf .= $prefix . "├─ " . $cb->( $t->{_items}[$i] ) . "\n";
188 12         1373 $buf = _to_string( $t, $cb, $i, $buf, $prefix . "│ " );
189             }
190              
191             # last child
192 7         9 my $i = $c_idxs->[-1];
193 7         20 $buf .= $prefix . "└─ " . $cb->( $t->{_items}[$i] ) . "\n";
194 7         642 $buf = _to_string( $t, $cb, $i, $buf, $prefix . " " );
195              
196 7         15 return $buf;
197             }
198              
199             # walk the tree, call the cb for every item with:
200             # my $err = $cb->(
201             # {
202             # depth => $depth,
203             # item => $item,
204             # parent => $parent,
205             # childs => [@childs],
206             # }
207             # );
208             #
209             sub _walk {
210 11     11   21 my ( $t, $cb, $depth, $p, $i ) = @_;
211              
212 11         12 my $parent;
213 11 100       17 if ( defined $p ) {
214 8         13 $parent = $t->{_items}[$p];
215             }
216              
217 11         14 my $item = $t->{_items}[$i];
218 11         17 my $c_idxs = $t->{_tree}{$i};
219              
220 11         11 my @childs;
221 11         17 foreach my $c (@$c_idxs) {
222 8         14 push @childs, $t->{_items}[$c];
223             }
224              
225 11         47 my $err = $cb->(
226             {
227             depth => $depth,
228             item => $item,
229             parent => $parent,
230             childs => [@childs],
231             }
232             );
233              
234 11 100       1711 return $err if $err;
235              
236 10         19 foreach my $c (@$c_idxs) {
237 8         23 my $err = _walk( $t, $cb, $depth + 1, $i, $c );
238 8 100       17 return $err if $err;
239             }
240              
241 8         12 return;
242             }
243              
244             =head1 AUTHOR
245              
246             Karl Gaissmaier, C<< >>
247              
248             =head1 SUPPORT
249              
250             You can find documentation for this module with the perldoc command.
251              
252             perldoc Net::IPAM::Tree::Private
253              
254             You can also look for information at:
255              
256             =over 4
257              
258             =item * on github
259              
260             TODO
261              
262             =back
263              
264             =head1 LICENSE AND COPYRIGHT
265              
266             This software is copyright (c) 2020-2022 by Karl Gaissmaier.
267              
268             This is free software; you can redistribute it and/or modify it under
269             the same terms as the Perl 5 programming language system itself.
270              
271             =encoding utf8
272              
273              
274             =cut
275              
276             1;