File Coverage

blib/lib/Net/CIDR/Lookup.pm
Criterion Covered Total %
statement 115 127 90.5
branch 43 62 69.3
condition 28 41 68.2
subroutine 24 25 96.0
pod 10 10 100.0
total 220 265 83.0


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Net::CIDR::Lookup
4              
5             =head1 DESCRIPTION
6              
7             This class implements a lookup table indexed by IPv4 networks or hosts.
8              
9             =over 1
10              
11             =item Addresses are accepted in numeric form (integer with separate netbits argument),
12             as strings in CIDR notation or as IP address ranges
13              
14             =item Overlapping or adjacent networks are automatically coalesced if their
15             associated values are equal.
16              
17             =item The table is implemented as a binary tree so lookup and insertion take O(log n)
18             time.
19              
20             =back
21              
22             Since V0.5, errors are signalled by an exception so method calls should generally by wrapped in an C.
23              
24             =head1 SYNOPSIS
25              
26             use Net::CIDR::Lookup;
27              
28             $cidr = Net::CIDR::Lookup->new;
29             $cidr->add("192.168.42.0/24",1); # Add first network, value 1
30             $cidr->add_num(167772448,27,2); # 10.0.1.32/27 => 2
31             $cidr->add("192.168.43.0/24",1); # Automatic coalescing to a /23
32             $cidr->add("192.168.41.0/24",2); # Stays separate due to different value
33             $cidr->add("192.168.42.128/25",2); # Error: overlaps with different value
34              
35             $val = $cidr->lookup("192.168.41.123"); # => 2
36              
37             $h = $cidr->to_hash; # Convert tree to a hash
38             print "$k => $v\n" while(($k,$v) = each %$h);
39              
40             # Output (order may vary):
41             # 192.168.42.0/23 => 1
42             # 10.0.1.32/27 => 2
43             # 192.168.41.0/24 => 2
44              
45             $cidr->walk(sub {
46             my ($addr, $bits, $val) = @_;
47             print join('.', unpack 'C*', pack 'N', $addr), "/$bits => $val\n"
48             }
49             );
50              
51             # Output (fixed order):
52             # 10.0.1.32/27 => 2
53             # 192.168.41.0/24 => 2
54             # 192.168.42.0/23 => 1
55              
56             $cidr->clear; # Remove all entries
57             $cidr->add_range('1.2.3.11 - 1.2.4.234', 42); # Add a range of addresses,
58             # automatically split into CIDR blocks
59             $h = $cidr->to_hash;
60             print "$k => $v\n" while(($k,$v) = each %$h);
61              
62             # Output (order may vary):
63             # 1.2.4.128/26 => 42
64             # 1.2.3.32/27 => 42
65             # 1.2.3.64/26 => 42
66             # 1.2.4.234/32 => 42
67             # 1.2.4.0/25 => 42
68             # 1.2.3.12/30 => 42
69             # 1.2.3.128/25 => 42
70             # 1.2.3.16/28 => 42
71             # 1.2.4.224/29 => 42
72             # 1.2.4.232/31 => 42
73             # 1.2.3.11/32 => 42
74             # 1.2.4.192/27 => 42
75              
76             =head1 VERSION HISTORY
77              
78             See L
79              
80             =head1 METHODS
81              
82             =cut
83              
84             package Net::CIDR::Lookup;
85 2     2   13139 use strict;
  2         3  
  2         41  
86 2     2   30 use 5.008008;
  2         4  
87 2     2   924 use integer;
  2         19  
  2         7  
88 2     2   45 use Carp;
  2         2  
  2         99  
89 2     2   503 use Socket qw/ inet_ntop inet_pton AF_INET /;
  2         2468  
  2         426  
90              
91             our $VERSION = '0.54';
92              
93             BEGIN {
94             # IPv4 address from dotted-quad to integer
95             # Choose manual implementation on Windows where inet_pton() is not available
96 2 50   2   9 if('MSWin32' eq $^O) {
97             *_dq2int = sub { ## no critic (Subroutines::RequireArgUnpacking)
98 0         0 my @oct = split /\./, $_[0];
99 0 0       0 4 == @oct or croak "address must be in dotted-quad form, is `$_[0]'";
100 0         0 my $ip = 0;
101 0         0 foreach(@oct) {
102 0 0 0     0 $_ <= 255 and $_ >= 0
103             or croak "invalid component `$_' in address `$_[0]'";
104 0         0 $ip = $ip<<8 | $_;
105             }
106 0         0 return $ip;
107 0         0 };
108             } else {
109 2     47   1924 *_dq2int = sub { unpack 'N', inet_pton(AF_INET, shift) };
  47         177  
110             }
111             }
112              
113             =head2 new
114              
115             Arguments: none
116              
117             Return Value: new object
118              
119             =cut
120              
121 24     24 1 23537 sub new { bless [], shift }
122              
123             =head2 add
124              
125             Arguments: C<$cidr>, C<$value>
126              
127             Return Value: none
128              
129             Adds VALUE to the tree under the key CIDR. CIDR must be a string containing an
130             IPv4 address followed by a slash and a number of network bits. Bits to the
131             right of this mask will be ignored.
132              
133             =cut
134              
135             sub add {
136 30     30 1 1793 my ($self, $cidr, $val) = @_;
137              
138 30 50       50 defined $val or croak "can't store an undef";
139              
140 30         143 my ($net, $bits) = $cidr =~ m{ ^ ([.[:digit:]]+) / (\d+) $ }ox;
141 30 50 33     112 defined $net and defined $bits or croak 'CIDR syntax error: use
/';
142 30 50       34 my $intnet = _dq2int($net) or return;
143 30         52 $self->_add($intnet,$bits,$val);
144             }
145              
146             =head2 add_range
147              
148             Arguments: C<$range>, C<$value>
149              
150             Return Value: none
151              
152             Adds VALUE to the tree for each address included in RANGE which must be a
153             hyphenated range of IP addresses in dotted-quad format (e.g.
154             "192.168.0.150-192.168.10.1") and with the first address being numerically
155             smaller the second. This range will be split up into as many CIDR blocks as
156             necessary (algorithm adapted from a script by Dr. Liviu Daia).
157              
158             =cut
159              
160             sub add_range {
161 4     4 1 211 my ($self, $range, $val) = @_;
162              
163 4 50       7 defined $val or croak "can't store an undef";
164              
165 4         22 my ($start, $end, $crud) = split /\s*-\s*/, $range;
166 4 50 33     19 croak 'must have exactly one hyphen in range'
167             if(defined $crud or not defined $end);
168              
169 4         7 $self->add_num_range(_dq2int($start), _dq2int($end), $val);
170             }
171              
172             =head2 add_num
173              
174             Arguments: C<$address>, C<$bits>, C<$value>
175              
176             Return Value: none
177              
178             Like C but accepts address and bits as separate integer arguments
179             instead of a string.
180              
181             =cut
182              
183             sub add_num { ## no critic (Subroutines::RequireArgUnpacking)
184             # my ($self,$ip,$bits,$val) = @_;
185             # Just call the recursive adder for now but allow for changes in object
186             # representation ($self != $n)
187 21 50   21 1 25 defined $_[3] or croak "can't store an undef";
188 21         19 _add(@_);
189             }
190              
191             =head2 add_num_range
192              
193             Arguments: C<$start>, C<$end>, C<$value>
194              
195             Return Value: none
196              
197             Like C but accepts addresses as separate integer arguments instead
198             of a range string.
199              
200             =cut
201              
202             sub add_num_range {
203 4     4 1 5 my ($self, $start, $end, $val) = @_;
204 4         2 my @chunks;
205              
206 4 50       9 $start > $end
207             and croak sprintf "start > end in range %s--%s", _int2dq($start), _int2dq($end);
208              
209 4         7 _do_chunk(\@chunks, $start, $end, 31, 0);
210 4         11 $self->add_num(@$_, $val) for(@chunks);
211             }
212              
213             =head2 lookup
214              
215             Arguments: C<$address>
216              
217             Return Value: value assoiated with this address or C
218              
219             Looks up an address and returns the value associated with the network
220             containing it. So far there is no way to tell which network that is though.
221              
222             =cut
223              
224             sub lookup {
225 9     9 1 17 my ($self, $addr) = @_;
226              
227             # Make sure there is no network spec tacked onto $addr
228 9         10 $addr =~ s!/.*!!;
229 9         12 $self->_lookup(_dq2int($addr));
230             }
231              
232              
233             =head2 lookup_num
234              
235             Arguments: C<$address>
236              
237             Return Value: value assoiated with this address or C
238              
239             Like C but accepts the address in integer form.
240              
241             =cut
242              
243 2     2 1 26 sub lookup_num { shift->_lookup($_[0]) } ## no critic (Subroutines::RequireArgUnpacking)
244              
245             =head2 to_hash
246              
247             Arguments: none
248              
249             Return Value: C<$hashref>
250              
251             Returns a hash representation of the tree with keys being CIDR-style network
252             addresses.
253              
254             =cut
255              
256             sub to_hash {
257 11     11 1 30 my ($self) = @_;
258 11         9 my %result;
259             $self->_walk(0, 0, sub {
260 30     30   40 my $net = _int2dq($_[0]) . '/' . $_[1];
261 30 50       57 if(defined $result{$net}) {
262 0         0 confess("internal error: network $net mapped to $result{$net} already!\n");
263             } else {
264 30         92 $result{$net} = $_[2];
265             }
266             }
267 11         45 );
268 11         56 return \%result;
269             }
270              
271             =head2 walk
272              
273             Arguments: C<$coderef> to call for each tree entry. Callback arguments are:
274              
275             =over 1
276              
277             =item C<$address>
278              
279             The network address in integer form
280              
281             =item C<$bits>
282              
283             The current CIDR block's number of network bits
284              
285             =item C<$value>
286              
287             The value associated with this block
288              
289             =back
290              
291             Return Value: none
292              
293             =cut
294              
295 0     0 1 0 sub walk { $_[0]->_walk(0, 0, $_[1]) } ## no critic (Subroutines::RequireArgUnpacking)
296              
297              
298             =head2 clear
299              
300             Arguments: none
301              
302             Return Value: none
303              
304             Remove all entries from the tree.
305              
306             =cut
307              
308             sub clear {
309 1     1 1 5 my $self = shift;
310 1         7 undef @$self;
311             }
312              
313             =head1 BUGS
314              
315             =over 1
316              
317             =item
318              
319             I didn't need deletions yet and deleting parts of a CIDR block is a bit more
320             complicated than anything this class does so far, so it's not implemented.
321              
322             =item
323              
324             Storing an C value does not work and yields an error. This would be
325             relatively easy to fix at the cost of some memory so that's more a design
326             decision.
327              
328             =back
329              
330             =head1 AUTHORS, COPYRIGHTS & LICENSE
331              
332             Matthias Bethke
333             while working for 1&1 Internet AG
334              
335             Licensed unter the Artistic License 2.0
336              
337             =head1 SEE ALSO
338              
339             This module's methods are based loosely on those of C
340              
341             =cut
342              
343             # Walk through a subtree and insert a network
344             sub _add {
345 51     51   47 my ($node, $addr, $nbits, $val) = @_;
346 51         37 my ($bit, $checksub);
347 0         0 my @node_stack;
348              
349             DESCEND:
350 51         34 while(1) {
351 1242 100       1177 $bit = $addr & 0x80000000 ? 1 : 0;
352 1242         645 $addr <<= 1;
353              
354 1242 100       1445 if(__PACKAGE__ ne ref $node) {
355 4 100       23 return 1 if($val eq $node); # Compatible entry (tried to add a subnet of one already in the tree)
356 1         20 croak "incompatible entry, found `$node' trying to add `$val'";
357             }
358 1238 100       1368 last DESCEND unless --$nbits;
359 1191 100       1067 if(defined $node->[$bit]) {
360 661         426 $checksub = 1;
361             } else {
362 530   50     1153 $node->[$bit] ||= bless([], __PACKAGE__);
363 530         374 $checksub = 0;
364             }
365 1191         847 push @node_stack, \$node->[$bit];
366 1191         812 $node = $node->[$bit];
367             }
368            
369             $checksub
370 47 100 100     115 and defined $node->[$bit]
      100        
371             and __PACKAGE__ eq ref $node->[$bit]
372             and _add_check_subtree($node->[$bit], $val);
373              
374 47         46 $node->[$bit] = $val;
375              
376             # Take care of potential mergers into the previous node (if $node[0] == $node[1])
377             not @node_stack
378 47 0 33     82 and defined $node->[$bit ^ 1]
      33        
379             and $node->[$bit ^ 1] eq $val
380             and croak 'merging two /1 blocks is not supported yet';
381 47         32 while(1) {
382 51         37 $node = pop @node_stack;
383             last unless(
384 51 100 66     321 defined $node
      100        
      100        
385             and defined $$node->[0]
386             and defined $$node->[1]
387             and $$node->[0] eq $$node->[1]
388             );
389 4         8 $$node = $val;
390             }
391             }
392              
393             # Check an existing subtree for incompatible values. Returns false and sets the
394             # package-global error string if there was a problem.
395             sub _add_check_subtree {
396 2     2   3 my ($root, $val) = @_;
397              
398             eval {
399             $root->_walk(0, 0, sub {
400 2     2   2 my $oldval = $_[2];
401 2 50       8 $val == $oldval or die $oldval; ## no critic (ErrorHandling::RequireCarping)
402             }
403 2         7 );
404 2         8 1;
405 2 50       3 } or do {
406 0 0       0 $@ and croak "incompatible entry, found `$@' trying to add `$val'";
407             };
408 2         2 return 1;
409             }
410              
411             sub _lookup {
412 11     11   32 my ($node, $addr) = @_;
413 11         8 my $bit;
414              
415 11         7 while(1) {
416 202         121 $bit = ($addr & 0x80000000) >> 31;
417 202 100       227 defined $node->[$bit] or return;
418 199 100       240 __PACKAGE__ ne ref $node->[$bit] and return $node->[$bit];
419 191         113 $node = $node->[$bit];
420 191         109 $addr <<= 1;
421             }
422             }
423              
424             # IPv4 address from integer to dotted-quad
425 30     30   171 sub _int2dq { inet_ntop(AF_INET, pack 'N', shift) }
426              
427             # Convert a CIDR block ($addr, $bits) into a range of addresses ($lo, $hi)
428             # sub _cidr2rng { ( $_[0], $_[0] | ((1 << $_[1]) - 1) ) }
429              
430             # Walk the tree in depth-first LTR order
431             sub _walk {
432 13     13   15 my ($node, $addr, $bits, $cb) = @_;
433 13         8 my ($l, $r);
434 13         22 my @node_stack = ($node, $addr, $bits);
435             #print "================== WALK ==================: ", join(':',caller),"\n";
436 13         22 while(@node_stack) {
437 343         344 ($node, $addr, $bits) = splice @node_stack, -3; # pop 3 elems
438             #print "LOOP: stack size ".(@node_stack/3)."\n";
439 343 100       407 if(__PACKAGE__ eq ref $node) {
440 328         313 ($l, $r) = @$node;
441             #printf "Popped [%s, %s]:%s/%d\n",
442             # ($l//'') =~ /^Net::CIDR::Lookup=/ ? '' : $l//'',
443             # ($r//'') =~ /^Net::CIDR::Lookup=/ ? '' : $r//'',
444             # _int2dq($addr), $bits;
445 328         217 ++$bits;
446              
447             # Check left side
448             #$addr &= ~(1 << 31-$bits);
449 328 100       335 if(__PACKAGE__ eq ref $l) {
450             #defined $r and print "L: pushing right node=$r, bits=$bits\n";
451 236 100       300 defined $r and push @node_stack, ($r, $addr | 1 << 32-$bits, $bits);
452             #print "L: pushing left node=$l, bits=$bits\n";
453 236         221 push @node_stack, ($l, $addr, $bits);
454             #printf "L: addr=%032b (%s)\n", $addr, _int2dq($addr);
455 236         307 next; # Short-circuit back to loop w/o checking $r!
456             } else {
457             #defined $l and printf "L: CALLBACK (%s/%d) => %s\n", _int2dq($addr), $bits, $l;
458 92 100       138 defined $l and $cb->($addr, $bits, $l);
459             }
460             } else {
461             # There was a right-side leaf node on the stack that will end up in
462             # the "else" branch below
463             #print "Found leftover right leaf $node\n";
464 15         18 $r = $node;
465             }
466              
467             # Check right side
468 107         83 $addr |= 1 << 32-$bits;
469 107 100       121 if(__PACKAGE__ eq ref $r) {
470             #print "R: pushing right node=$r, bits=$bits\n";
471 75         122 push @node_stack, ($r, $addr, $bits);
472             #printf "R: addr=%032b (%s)\n", $addr, _int2dq($addr);
473             } else {
474             #defined $r and printf "R: CALLBACK (%s/%d) => %s\n", _int2dq($addr), $bits, $r;
475 32 100       77 defined $r and $cb->($addr, $bits, $r);
476             }
477             }
478             }
479              
480             # Split a chunk into a minimal number of CIDR blocks.
481             sub _do_chunk {
482 38     38   24 my ($chunks, $start, $end, $ix1, $ix2) = @_;
483 38         23 my ($prefix, $xor);
484              
485             # Find common prefix. After that, the bit indicated by $ix1 is 0 for $start
486             # and 1 for $end. A split a this point guarantees the longest suffix.
487 38         23 $xor = $start ^ $end;
488 38   100     314 --$ix1 until($xor & 1 << $ix1 or -1 == $ix1);
489 38         30 $prefix = $start & ~((1 << ($ix1+1)) - 1);
490              
491 38   100     453 $ix2++ while($ix2 <= $ix1
      100        
492             and not ($start & 1 << $ix2)
493             and ($end & 1 << $ix2));
494              
495             # Split if $fbits and $lbits disagree on the length of the chunk.
496 38 100       35 if ($ix2 <= $ix1) {
497 17         51 _do_chunk($chunks, $start, $prefix | ((1<<$ix1) - 1), $ix1, $ix2);
498 17         22 _do_chunk($chunks, $prefix | (1<<$ix1), $end, $ix1, $ix2);
499             } else {
500 21         35 push @$chunks, [ $prefix, 31-$ix1 ];
501             }
502             }
503              
504             1;