File Coverage

blib/lib/Net/IPAM/Tree.pm
Criterion Covered Total %
statement 68 68 100.0
branch 30 30 100.0
condition 3 3 100.0
subroutine 15 15 100.0
pod 6 6 100.0
total 122 122 100.0


line stmt bran cond sub pod time code
1             package Net::IPAM::Tree;
2              
3             our $VERSION = '3.02';
4              
5 6     6   349479 use 5.10.0;
  6         109  
6 6     6   31 use strict;
  6         9  
  6         156  
7 6     6   29 use warnings;
  6         9  
  6         178  
8 6     6   2061 use utf8;
  6         77  
  6         33  
9              
10 6     6   235 use Carp qw();
  6         11  
  6         85  
11 6     6   24 use Scalar::Util qw();
  6         11  
  6         83  
12              
13 6     6   2117 use Net::IPAM::Tree::Private qw();
  6         17  
  6         138  
14 6     6   2860 use Net::IPAM::Block qw();
  6         85025  
  6         3496  
15              
16             =head1 NAME
17              
18             Net::IPAM::Tree - A CIDR/Block tree library for fast IP lookup with longest-prefix-match.
19              
20             =head1 DESCRIPTION
21              
22             A module for fast IP-routing-table lookups and IP-ACLs (Access Control Lists).
23              
24             It is B a standard patricia-trie implementation.
25             This isn't possible for general blocks not represented by bitmasks.
26             Every tree item is a Net::IPAM::Block or a subclass of it.
27              
28             =encoding utf8
29              
30             =head1 SYNOPSIS
31              
32             use Net::IPAM::Tree;
33              
34             my ($t, $dups) = Net::IPAM::Tree->new(@blocks);
35             if (@$dups) {
36             warn("items are duplicate: " . join("\n", @$dups));
37             }
38              
39             my $block = $t->lookup($ip_or_block)
40             && printf( "longest-prefix-match in tree for %s is %s\n", $ip_or_block, $block );
41              
42             my $superset = $t->superset($ip_or_block)
43             && printf( "superset in tree for ip or block %s is %s\n", $ip_or_block, $superset );
44              
45             say $t->to_string;
46              
47            
48             ├─ ::/8
49             ├─ 100::/8
50             ├─ 2000::/3
51             │ ├─ 2000::/4
52             │ └─ 3000::/4
53             ├─ 4000::/3
54             ...
55              
56             =head1 METHODS
57              
58             =head2 new(@blocks)
59              
60             Create Net::IPAM::Tree object.
61              
62             my ($t, $dups) = Net::IPAM::Tree->new(@blocks);
63              
64             In scalar context just returns the tree object, duplicate items produce a warning.
65              
66             In list context returns the tree object and the arrayref of duplicate items, if any.
67              
68             =cut
69              
70             sub new {
71 10     10 1 3435 my $self = bless {}, shift;
72              
73 10         39 $self->{_items} = [ Net::IPAM::Block::sort_block(@_) ];
74 10         385 $self->{_tree} = {}; # {parent_idx}->[child_idxs]
75              
76 10         19 my @dups;
77 10         20 for ( my $i = 0 ; $i < @{ $self->{_items} } ; $i++ ) {
  48         94  
78              
79             # check for dups
80 38 100 100     122 if ( $i > 0 && $self->{_items}[$i]->cmp( $self->{_items}[ $i - 1 ] ) == 0 ) {
81 2         16 push @dups, $self->{_items}[$i];
82 2         3 next;
83             }
84              
85 36         217 Net::IPAM::Tree::Private::_build_index_tree( $self, '_ROOT', $i );
86             }
87              
88 10 100       26 if (wantarray) {
89 1         5 return ( $self, \@dups );
90             }
91              
92 9 100       22 if (@dups) {
93 1         137 Carp::carp('duplicate items,');
94             }
95              
96 9         92 return $self;
97             }
98              
99             =head2 superset($thing)
100              
101             Returns the outermost block if the given $thing (L or L)
102             is contained in the tree or undef.
103              
104             =cut
105              
106             sub superset {
107 11     11 1 4387 my ( $self, $thing ) = @_;
108 11 100       172 Carp::croak("missing or wrong arg,") unless Scalar::Util::blessed($thing);
109              
110             # make a /32 or /128 block if thing is an IP
111 9 100       54 $thing = Net::IPAM::Block->new($thing) if $thing->isa('Net::IPAM::IP');
112              
113 9 100       122 Carp::croak("wrong arg,") unless $thing->isa('Net::IPAM::Block');
114              
115 8         19 return Net::IPAM::Tree::Private::_superset( $self, $thing );
116             }
117              
118             =head2 lookup($thing)
119              
120             Returns L with longest prefix match for $thing (L or L)
121             in the tree, undef if not found.
122              
123             This can be used for ACL or fast routing table lookups.
124              
125             # make blocks
126             my @priv = map { Net::IPAM::Block->new($_) } qw(10.0.0.0/8 172.16.0.0/12 192.168.0.0 fc00::/7);
127              
128             # make tree
129             my $priv = Net::IPAM::Tree->new(@priv);
130              
131             my $b = Net::IPAM::Block->new('fdcd:aa59:8bce::/48') or die;
132              
133             my $lpm = $priv->lookup($b)
134             && say "longest-prefix-match for $b is $lpm";
135              
136             =cut
137              
138             sub lookup {
139 14     14 1 5462 my ( $self, $thing ) = @_;
140 14 100       173 Carp::croak("missing or wrong arg,") unless Scalar::Util::blessed($thing);
141              
142             # make a /32 or /128 block if thing is an IP
143 12 100       50 $thing = Net::IPAM::Block->new($thing) if $thing->isa('Net::IPAM::IP');
144              
145 12 100       102 Carp::croak("wrong arg,") unless $thing->isa('Net::IPAM::Block');
146              
147 11         24 return Net::IPAM::Tree::Private::_lookup( $self, '_ROOT', $thing );
148             }
149              
150             =head2 to_string
151              
152             Returns the tree as ordered graph or undef on empty trees.
153              
154             $t->to_string($callback);
155              
156             The optional callback is called on every block. Returns the decorated string for block.
157              
158             $t->to_string( sub { my $block = shift; return decorate($block) } );
159              
160             example (without callback):
161              
162            
163             ├─ ::/8
164             ├─ 100::/8
165             ├─ 2000::/3
166             │ ├─ 2000::/4
167             │ └─ 3000::/4
168             ├─ 6000::/3
169              
170             possible example (with callback):
171              
172            
173             ├─ ::/8................. "Reserved by IETF [RFC3513][RFC4291]"
174             ├─ 100::/8.............. "Reserved by IETF [RFC3513][RFC4291]"
175             ├─ 2000::/3............. "Global Unicast [RFC3513][RFC4291]"
176             │ ├─ 2000::/4............. "Test"
177             │ └─ 3000::/4............. "FREE"
178             ├─ 6000::/3............. "Reserved by IETF [RFC3513][RFC4291]"
179              
180             =cut
181              
182             sub to_string {
183 5     5 1 541 my ( $self, $cb ) = @_;
184              
185 5 100       15 if ( defined $cb ) {
186 2 100       168 Carp::croak("attribute 'cb' is no CODE_REF,") unless ref $cb eq 'CODE';
187             }
188             else {
189 3     9   12 $cb = sub { return "$_[0]" };
  9         22  
190             }
191              
192 4         7 my $prefix = '';
193 4         5 my $buf = '';
194              
195 4         14 $buf = Net::IPAM::Tree::Private::_to_string( $self, $cb, '_ROOT', $buf, $prefix );
196              
197 4 100       24 return "▼\n" . $buf if $buf;
198 1         4 return;
199             }
200              
201             =head2 walk($walk_func)
202              
203             Walks the ordered tree, see L.
204              
205             my $err_string = $t->walk($walk_func);
206              
207             For every item the walk_func function is called with the following hash-ref:
208              
209             my $err = $walk_func->(
210             {
211             depth => $i, # starts at 0
212             item => $item, # current block
213             parent => $parent, # parent block, undef for root items
214             childs => [@childs], # child blocks, empty for leaf items
215             }
216             );
217              
218             The current depth is counting from 0.
219              
220             On error, the walk is stopped and the error is returned to the caller.
221             The walk_func B return undef if there is no error!
222              
223             =cut
224              
225             sub walk {
226 5     5 1 1260 my ( $self, $cb ) = @_;
227 5 100       132 Carp::croak("missing arg,") unless defined $cb;
228 4 100       70 Carp::croak("wrong arg, callback is no CODE_REF,") unless ref $cb eq 'CODE';
229              
230 3         3 foreach my $c ( @{ $self->{_tree}{_ROOT} } ) {
  3         9  
231 3         8 my $err = Net::IPAM::Tree::Private::_walk( $self, $cb, 0, undef, $c );
232 3 100       8 return $err if defined $err;
233             }
234              
235 2         4 return;
236             }
237              
238             =head2 len
239              
240             Returns the number of blocks in the tree.
241              
242             =cut
243              
244             sub len {
245 1     1 1 2 return scalar @{ $_[0]->{_items} };
  1         4  
246             }
247              
248             =head1 AUTHOR
249              
250             Karl Gaissmaier, C<< >>
251              
252             =head1 SUPPORT
253              
254             You can find documentation for this module with the perldoc command.
255              
256             perldoc Net::IPAM::Tree
257              
258             You can also look for information at:
259              
260             =over 4
261              
262             =item * on github
263              
264             TODO
265              
266             =back
267              
268             =head1 SEE ALSO
269              
270             L
271             L
272              
273             =head1 LICENSE AND COPYRIGHT
274              
275             This software is copyright (c) 2020-2022 by Karl Gaissmaier.
276              
277             This is free software; you can redistribute it and/or modify it under
278             the same terms as the Perl 5 programming language system itself.
279              
280             =cut
281              
282             1; # End of Net::IPAM::Tree