← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:11 2021

Filename/usr/local/lib/perl5/site_perl/Net/CIDR.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sNet::CIDR::::BEGIN@18Net::CIDR::BEGIN@18
0000s0sNet::CIDR::::_add1Net::CIDR::_add1
0000s0sNet::CIDR::::_cidr2iprangeNet::CIDR::_cidr2iprange
0000s0sNet::CIDR::::_cidr2range8Net::CIDR::_cidr2range8
0000s0sNet::CIDR::::_h62dNet::CIDR::_h62d
0000s0sNet::CIDR::::_ipcmpNet::CIDR::_ipcmp
0000s0sNet::CIDR::::_iptoipaNet::CIDR::_iptoipa
0000s0sNet::CIDR::::_ipv4to6Net::CIDR::_ipv4to6
0000s0sNet::CIDR::::_ipv6to4Net::CIDR::_ipv6to4
0000s0sNet::CIDR::::_push_ipv6_octetsNet::CIDR::_push_ipv6_octets
0000s0sNet::CIDR::::_range2cidrNet::CIDR::_range2cidr
0000s0sNet::CIDR::::_range2cidr8Net::CIDR::_range2cidr8
0000s0sNet::CIDR::::_sub1Net::CIDR::_sub1
0000s0sNet::CIDR::::_triml0Net::CIDR::_triml0
0000s0sNet::CIDR::::addr2cidrNet::CIDR::addr2cidr
0000s0sNet::CIDR::::addrandmask2cidrNet::CIDR::addrandmask2cidr
0000s0sNet::CIDR::::cidr2octetsNet::CIDR::cidr2octets
0000s0sNet::CIDR::::cidr2rangeNet::CIDR::cidr2range
0000s0sNet::CIDR::::cidraddNet::CIDR::cidradd
0000s0sNet::CIDR::::cidrlookupNet::CIDR::cidrlookup
0000s0sNet::CIDR::::cidrvalidateNet::CIDR::cidrvalidate
0000s0sNet::CIDR::::range2cidrNet::CIDR::range2cidr
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1# Net::CIDR
2#
3# Copyright 2001-2021 Sam Varshavchik.
4#
5# with contributions from David Cantrell.
6#
7# This program is free software; you can redistribute it
8# and/or modify it under the same terms as Perl itself.
9
10package Net::CIDR;
11
12require 5.000;
13#use strict;
14#use warnings;
15
16require Exporter;
17# use AutoLoader qw(AUTOLOAD);
18use Carp;
19
20@ISA = qw(Exporter);
21
22# Items to export into callers namespace by default. Note: do not export
23# names by default without a very good reason. Use EXPORT_OK instead.
24# Do not simply export all your public functions/methods/constants.
25
26# This allows declaration use Net::CIDR ':all';
27# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
28# will save memory.
29%EXPORT_TAGS = ( 'all' => [ qw( range2cidr
30 cidr2range
31 cidr2octets
32 cidradd
33 cidrlookup
34 cidrvalidate
35 addr2cidr
36 addrandmask2cidr
37 ) ] );
38
39@EXPORT_OK = ( qw( range2cidr
40 cidr2range
41 cidr2octets
42 cidradd
43 cidrlookup
44 cidrvalidate
45 addr2cidr
46 addrandmask2cidr
47 ));
48
49@EXPORT = qw(
50
51);
52
53$VERSION = "0.21";
54
551;
56
57
58=pod
59
60=head1 NAME
61
62Net::CIDR - Manipulate IPv4/IPv6 netblocks in CIDR notation
63
64=head1 SYNOPSIS
65
66 use Net::CIDR;
67
68 use Net::CIDR ':all';
69
70 my $var;
71
72 if ($var = Net::CIDR::cidrvalidate($var))
73 {
74 // ... do something
75 }
76
77 print join("\n",
78 Net::CIDR::range2cidr("192.168.0.0-192.168.255.255",
79 "10.0.0.0-10.3.255.255"))
80 . "\n";
81 #
82 # Output from above:
83 #
84 # 192.168.0.0/16
85 # 10.0.0.0/14
86
87 print join("\n",
88 Net::CIDR::range2cidr(
89 "dead:beef::-dead:beef:ffff:ffff:ffff:ffff:ffff:ffff"))
90 . "\n";
91
92 #
93 # Output from above:
94 #
95 # dead:beef::/32
96
97 print join("\n",
98 Net::CIDR::range2cidr("192.168.1.0-192.168.2.255"))
99 . "\n";
100 #
101 # Output from above:
102 #
103 # 192.168.1.0/24
104 # 192.168.2.0/24
105
106 print join("\n", Net::CIDR::cidr2range("192.168.0.0/16")) . "\n";
107 #
108 # Output from above:
109 #
110 # 192.168.0.0-192.168.255.255
111
112 print join("\n", Net::CIDR::cidr2range("dead::beef::/46")) . "\n";
113 #
114 # Output from above:
115 #
116 # dead:beef::-dead:beef:3:ffff:ffff:ffff:ffff:ffff
117
118 @list=("192.168.0.0/24");
119 @list=Net::CIDR::cidradd("192.168.1.0-192.168.1.255", @list);
120
121 print join("\n", @list) . "\n";
122 #
123 # Output from above:
124 #
125 # 192.168.0.0/23
126
127 print join("\n", Net::CIDR::cidr2octets("192.168.0.0/22")) . "\n";
128 #
129 # Output from above:
130 #
131 # 192.168.0
132 # 192.168.1
133 # 192.168.2
134 # 192.168.3
135
136 print join("\n", Net::CIDR::cidr2octets("dead::beef::/46")) . "\n";
137 #
138 # Output from above:
139 #
140 # dead:beef:0000
141 # dead:beef:0001
142 # dead:beef:0002
143 # dead:beef:0003
144
145 @list=("192.168.0.0/24");
146 print Net::CIDR::cidrlookup("192.168.0.12", @list);
147 #
148 # Output from above:
149 #
150 # 1
151
152 @list = Net::CIDR::addr2cidr("192.168.0.31");
153 print join("\n", @list);
154 #
155 # Output from above:
156 #
157 # 192.168.0.31/32
158 # 192.168.0.30/31
159 # 192.168.0.28/30
160 # 192.168.0.24/29
161 # 192.168.0.16/28
162 # 192.168.0.0/27
163 # 192.168.0.0/26
164 # 192.168.0.0/25
165 # 192.168.0.0/24
166 # 192.168.0.0/23
167 # [and so on]
168
169 print Net::CIDR::addrandmask2cidr("195.149.50.61", "255.255.255.248")."\n";
170 #
171 # Output from above:
172 #
173 # 195.149.50.56/29
174
175=head1 DESCRIPTION
176
177The Net::CIDR package contains functions that manipulate lists of IP
178netblocks expressed in CIDR notation.
179The Net::CIDR functions handle both IPv4 and IPv6 addresses.
180
181The cidrvalidate() function, described below, checks that its argument
182is a single, valid IP address or a CIDR. The remaining functions
183expect that
184their parameters consist of validated IPs or CIDRs. See cidrvalidate()
185and BUGS, below, for more information.
186
187=head2 @cidr_list=Net::CIDR::range2cidr(@range_list);
188
189Each element in the @range_list is a string "start-finish", where
190"start" is the first IP address and "finish" is the last IP address.
191range2cidr() converts each range into an equivalent CIDR netblock.
192It returns a list of netblocks except in the case where it is given
193only one parameter and is called in scalar context.
194
195For example:
196
197 @a=Net::CIDR::range2cidr("192.168.0.0-192.168.255.255");
198
199The result is a one-element array, with $a[0] being "192.168.0.0/16".
200range2cidr() processes each "start-finish" element in @range_list separately.
201But if invoked like so:
202
203 $a=Net::CIDR::range2cidr("192.168.0.0-192.168.255.255");
204
205The result is a scalar "192.168.0.0/16".
206
207Where each element cannot be expressed as a single CIDR netblock
208range2cidr() will generate as many CIDR netblocks as are necessary to cover
209the full range of IP addresses. Example:
210
211 @a=Net::CIDR::range2cidr("192.168.1.0-192.168.2.255");
212
213The result is a two element array: ("192.168.1.0/24","192.168.2.0/24");
214
215 @a=Net::CIDR::range2cidr(
216 "d08c:43::-d08c:43:ffff:ffff:ffff:ffff:ffff:ffff");
217
218The result is an one element array: ("d08c:43::/32") that reflects this
219IPv6 netblock in CIDR notation.
220
221range2cidr() does not merge adjacent or overlapping netblocks in
222@range_list.
223
224=head2 @range_list=Net::CIDR::cidr2range(@cidr_list);
225
226The cidr2range() functions converts a netblock list in CIDR notation
227to a list of "start-finish" IP address ranges:
228
229 @a=Net::CIDR::cidr2range("10.0.0.0/14", "192.168.0.0/24");
230
231The result is a two-element array:
232("10.0.0.0-10.3.255.255", "192.168.0.0-192.168.0.255").
233
234 @a=Net::CIDR::cidr2range("d08c:43::/32");
235
236The result is a one-element array:
237("d08c:43::-d08c:43:ffff:ffff:ffff:ffff:ffff:ffff").
238
239cidr2range() does not merge adjacent or overlapping netblocks in
240@cidr_list.
241
242=head2 @netblock_list = Net::CIDR::addr2cidr($address);
243
244The addr2cidr function takes an IP address and returns a list of all
245the CIDR netblocks it might belong to:
246
247 @a=Net::CIDR::addr2cidr('192.168.0.31');
248
249The result is a thirtythree-element array:
250('192.168.0.31/32', '192.168.0.30/31', '192.168.0.28/30', '192.168.0.24/29',
251 [and so on])
252consisting of all the possible subnets containing this address from
2530.0.0.0/0 to address/32.
254
255Any addresses supplied to addr2cidr after the first will be ignored.
256It works similarly for IPv6 addresses, returning a list of one hundred
257and twenty nine elements.
258
259=head2 $cidr=Net::CIDR::addrandmask2cidr($address, $netmask);
260
261The addrandmask2cidr function takes an IP address and a netmask, and
262returns the CIDR range whose size fits the netmask and which contains
263the address. It is an error to supply one parameter in IPv4-ish
264format and the other in IPv6-ish format, and it is an error to supply
265a netmask which does not consist solely of 1 bits followed by 0 bits.
266For example, '255.255.248.192' is an invalid netmask, as is
267'255.255.255.32' because both contain 0 bits in between 1 bits.
268
269Technically speaking both of those *are* valid netmasks, but a) you'd
270have to be insane to use them, and b) there's no corresponding CIDR
271range.
272
273=cut
274
275# CIDR to start-finish
276
277sub cidr2range {
278 my @cidr=@_;
279
280 my @r;
281
282 while ($#cidr >= 0)
283 {
284 my $cidr=shift @cidr;
285
286 $cidr =~ s/\s//g;
287
288 unless ($cidr =~ /(.*)\/(.*)/)
289 {
290 push @r, $cidr;
291 next;
292 }
293
294 my ($ip, $pfix)=($1, $2);
295
296 my $isipv6;
297
298 my @ips=_iptoipa($ip);
299
300 $isipv6=shift @ips;
301
302 croak "$pfix, as in '$cidr', does not make sense"
303 unless $pfix >= 0 && $pfix <= ($#ips+1) * 8 && $pfix =~ /^[0-9]+$/;
304
305 my @rr=_cidr2iprange($pfix, @ips);
306
307 while ($#rr >= 0)
308 {
309 my $a=shift @rr;
310 my $b=shift @rr;
311
312 $a =~ s/\.$//;
313 $b =~ s/\.$//;
314
315 if ($isipv6)
316 {
317 $a=_ipv4to6($a);
318 $b=_ipv4to6($b);
319 }
320
321 push @r, "$a-$b";
322 }
323 }
324
325 return @r;
326}
327
328#
329# If the input is an IPv6-formatted address, convert it to an IPv4 decimal
330# format, since the other functions know how to deal with it. The hexadecimal
331# IPv6 address is represented in dotted-decimal form, like IPv4.
332#
333
334sub _ipv6to4 {
335 my $ipv6=shift;
336
337 return (undef, $ipv6) unless $ipv6 =~ /:/;
338
339 croak "Syntax error: $ipv6"
340 unless $ipv6 =~ /^[a-fA-F0-9:\.]+$/;
341
342 my $ip4_suffix="";
343
344 ($ipv6, $ip4_suffix)=($1, $2)
345 if $ipv6 =~ /^(.*:)([0-9]+\.[0-9\.]+)$/;
346
347 $ipv6 =~ s/([a-fA-F0-9]+)/_h62d($1)/ge;
348
349 my $ipv6_suffix="";
350
351 if ($ipv6 =~ /(.*)::(.*)/)
352 {
353 ($ipv6, $ipv6_suffix)=($1, $2);
354 $ipv6_suffix .= ".$ip4_suffix";
355 }
356 else
357 {
358 $ipv6 .= ".$ip4_suffix";
359 }
360
361 my @p=grep (/./, split (/[^0-9]+/, $ipv6));
362
363 my @s=grep (/./, split (/[^0-9]+/, $ipv6_suffix));
364
365 push @p, 0 while $#p + $#s < 14;
366
367 my $n=join(".", @p, @s);
368
369# return (undef, $1)
370# if $n =~ /^0\.0\.0\.0\.0\.0\.0\.0\.0\.0\.255\.255\.(.*)$/;
371
372 return (1, $n);
373}
374
375# Let's go the other way around
376
377sub _ipv4to6 {
378 my @octets=split(/[^0-9]+/, shift);
379
380 croak "Internal error in _ipv4to6"
381 unless $#octets == 15;
382
383 my @dummy=@octets;
384
385 return ("::ffff:" . join(".", $octets[12], $octets[13], $octets[14], $octets[15]))
386 if join(".", splice(@dummy, 0, 12)) eq "0.0.0.0.0.0.0.0.0.0.255.255";
387
388 my @words;
389
390 my $i;
391
392 for ($i=0; $i < 8; $i++)
393 {
394 $words[$i]=sprintf("%x", $octets[$i*2] * 256 + $octets[$i*2+1]);
395 }
396
397 my $ind= -1;
398 my $indlen= -1;
399
400 for ($i=0; $i < 8; $i++)
401 {
402 next unless $words[$i] eq "0";
403
404 my $j;
405
406 for ($j=$i; $j < 8; $j++)
407 {
408 last if $words[$j] ne "0";
409 }
410
411 if ($j - $i > $indlen)
412 {
413 $indlen= $j-$i;
414 $ind=$i;
415 $i=$j-1;
416 }
417 }
418
419 return "::" if $indlen == 8;
420
421 return join(":", @words) if $ind < 0;
422
423 my @s=splice (@words, $ind+$indlen);
424
425 return join(":", splice (@words, 0, $ind)) . "::"
426 . join(":", @s);
427}
428
429# An IP address to an octet list.
430
431# Returns a list. First element, flag: true if it was an IPv6 flag. Remaining
432# values are octets.
433
434sub _iptoipa {
435 my $iparg=shift;
436
437 my $isipv6;
438 my $ip;
439
440 ($isipv6, $ip)=_ipv6to4($iparg);
441
442 my @ips= split (/\.+/, $ip);
443
444 grep {
445 croak "$_, in $iparg, is not a byte" unless $_ >= 0 && $_ <= 255 && $_ =~ /^[0-9]+$/;
446 } @ips;
447
448 return ($isipv6, @ips);
449}
450
451sub _h62d {
452 my $h=shift;
453
454 $h=hex("0x$h");
455
456 return ( int($h / 256) . "." . ($h % 256));
457}
458
459sub _cidr2iprange {
460 my @ips=@_;
461 my $pfix=shift @ips;
462
463 if ($pfix == 0)
464 {
465 grep { $_=0 } @ips;
466
467 my @ips2=@ips;
468
469 grep { $_=255 } @ips2;
470
471 return ( join(".", @ips), join(".", @ips2));
472 }
473
474 if ($pfix >= 8)
475 {
476 my $octet=shift @ips;
477
478 @ips=_cidr2iprange($pfix - 8, @ips);
479
480 grep { $_="$octet.$_"; } @ips;
481 return @ips;
482 }
483
484 my $octet=shift @ips;
485
486 grep { $_=0 } @ips;
487
488 my @ips2=@ips;
489
490 grep { $_=255 } @ips2;
491
492 my @r= _cidr2range8(($octet, $pfix));
493
494 $r[0] = join (".", ($r[0], @ips));
495 $r[1] = join (".", ($r[1], @ips2));
496
497 return @r;
498}
499
500#
501# ADDRESS to list of CIDR netblocks
502#
503
504sub addr2cidr {
505 my @ips=_iptoipa(shift);
506
507 my $isipv6=shift @ips;
508
509 my $nbits;
510
511 if ($isipv6)
512 {
513 croak "An IPv6 address is 16 bytes long" unless $#ips == 15;
514 $nbits=128;
515 }
516 else
517 {
518 croak "An IPv4 address is 4 bytes long" unless $#ips == 3;
519 $nbits=32;
520 }
521
522 my @blocks;
523
524 foreach my $bits (reverse 0..$nbits)
525 {
526 my @ipcpy=@ips;
527
528 my $n=$bits;
529
530 while ($n < $nbits)
531 {
532 @ipcpy[$n / 8] &= (0xFF00 >> ($n % 8));
533
534 $n += 8;
535
536 $n &= 0xF8;
537 }
538
539 my $s=join(".", @ipcpy);
540
541 push @blocks, ($isipv6 ? _ipv4to6($s):$s) . "/$bits";
542 }
543 return @blocks;
544}
545
546# Address and netmask to CIDR
547
548sub addrandmask2cidr {
549 my $address = shift;
550 my($a_isIPv6) = _ipv6to4($address);
551 my($n_isIPv6, $netmask) = _ipv6to4(shift);
552 die("Both address and netmask must be the same type")
553 if( defined($a_isIPv6) && defined($n_isIPv6) && $a_isIPv6 != $n_isIPv6);
554 my $bitsInNetmask = 0;
555 my $previousNMoctet = 255;
556 foreach my $octet (split/\./, $netmask) {
557 die("Invalid netmask") if($previousNMoctet != 255 && $octet != 0);
558 $previousNMoctet = $octet;
559 $bitsInNetmask +=
560 ($octet == 255) ? 8 :
561 ($octet == 254) ? 7 :
562 ($octet == 252) ? 6 :
563 ($octet == 248) ? 5 :
564 ($octet == 240) ? 4 :
565 ($octet == 224) ? 3 :
566 ($octet == 192) ? 2 :
567 ($octet == 128) ? 1 :
568 ($octet == 0) ? 0 :
569 die("Invalid netmask");
570 }
571 return (grep { /\/$bitsInNetmask$/ } addr2cidr($address))[0];
572}
573
574#
575# START-FINISH to CIDR list
576#
577
578sub range2cidr {
579 my @r=@_;
580
581 my $i;
582
583 my @c;
584
585 for ($i=0; $i <= $#r; $i++)
586 {
587 $r[$i] =~ s/\s//g;
588
589 if ($r[$i] =~ /\//)
590 {
591 push @c, $r[$i];
592 next;
593 }
594
595 $r[$i]="$r[$i]-$r[$i]" unless $r[$i] =~ /(.*)-(.*)/;
596
597 $r[$i] =~ /(.*)-(.*)/;
598
599 my ($a,$b)=($1,$2);
600
601 my $isipv6_1;
602 my $isipv6_2;
603
604 ($isipv6_1, $a)=_ipv6to4($a);
605 ($isipv6_2, $b)=_ipv6to4($b);
606
607 if ($isipv6_1 || $isipv6_2)
608 {
609 croak "Invalid netblock range: $r[$i]"
610 unless $isipv6_1 && $isipv6_2;
611 }
612
613 my @a=split(/\.+/, $a);
614 my @b=split(/\.+/, $b);
615
616 croak unless $#a == $#b;
617
618 my @cc=_range2cidr(\@a, \@b);
619
620 while ($#cc >= 0)
621 {
622 $a=shift @cc;
623 $b=shift @cc;
624
625 $a=_ipv4to6($a) if $isipv6_1;
626
627 push @c, "$a/$b";
628 }
629 }
630 return @c unless(1==@r && 1==@c && !wantarray());
631 return $c[0];
632}
633
634sub _range2cidr {
635 my $a=shift;
636 my $b=shift;
637
638 my @a=@$a;
639 my @b=@$b;
640
641 $a=shift @a;
642 $b=shift @b;
643
644 return _range2cidr8($a, $b) if $#a < 0; # Least significant octet pair.
645
646 croak "Bad starting address\n" unless $a >= 0 && $a <= 255 && $a =~ /^[0-9]+$/;
647 croak "Bad ending address\n" unless $b >= 0 && $b <= 255 && $b =~ /^[0-9]+$/ && $b >= $a;
648
649 my @c;
650
651 if ($a == $b) # Same start/end octet
652 {
653 my @cc= _range2cidr(\@a, \@b);
654
655 while ($#cc >= 0)
656 {
657 my $c=shift @cc;
658
659 push @c, "$a.$c";
660
661 $c=shift @cc;
662 push @c, $c+8;
663 }
664 return @c;
665 }
666
667 my $start0=1;
668 my $end255=1;
669
670 grep { $start0=0 unless $_ == 0; } @a;
671 grep { $end255=0 unless $_ == 255; } @b;
672
673 if ( ! $start0 )
674 {
675 my @bcopy=@b;
676
677 grep { $_=255 } @bcopy;
678
679 my @cc= _range2cidr(\@a, \@bcopy);
680
681 while ($#cc >= 0)
682 {
683 my $c=shift @cc;
684
685 push @c, "$a.$c";
686
687 $c=shift @cc;
688 push @c, $c + 8;
689 }
690
691 ++$a;
692 }
693
694 if ( ! $end255 )
695 {
696 my @acopy=@a;
697
698 grep { $_=0 } @acopy;
699
700 my @cc= _range2cidr(\@acopy, \@b);
701
702 while ($#cc >= 0)
703 {
704 my $c=shift @cc;
705
706 push @c, "$b.$c";
707
708 $c=shift @cc;
709 push @c, $c + 8;
710 }
711
712 --$b;
713 }
714
715 if ($a <= $b)
716 {
717 grep { $_=0 } @a;
718
719 my $pfix=join(".", @a);
720
721 my @cc= _range2cidr8($a, $b);
722
723 while ($#cc >= 0)
724 {
725 my $c=shift @cc;
726
727 push @c, "$c.$pfix";
728
729 $c=shift @cc;
730 push @c, $c;
731 }
732 }
733 return @c;
734}
735
736sub _range2cidr8 {
737
738 my @c;
739
740 my @r=@_;
741
742 while ($#r >= 0)
743 {
744 my $a=shift @r;
745 my $b=shift @r;
746
747 croak "Bad starting address\n" unless $a >= 0 && $a <= 255 && $a =~ /^[0-9]+$/;
748 croak "Bad ending address\n" unless $b >= 0 && $b <= 255 && $b =~ /^[0-9]+$/ && $b >= $a;
749
750 ++$b;
751
752 while ($a < $b)
753 {
754 my $i=0;
755 my $n=1;
756
757 while ( ($n & $a) == 0)
758 {
759 ++$i;
760 $n <<= 1;
761 last if $i >= 8;
762 }
763
764 while ($i && $n + $a > $b)
765 {
766 --$i;
767 $n >>= 1;
768 }
769
770 push @c, $a;
771 push @c, 8-$i;
772
773 $a += $n;
774 }
775 }
776
777 return @c;
778}
779
780sub _cidr2range8 {
781
782 my @c=@_;
783
784 my @r;
785
786 while ($#c >= 0)
787 {
788 my $a=shift @c;
789 my $b=shift @c;
790
791 croak "Bad starting address" unless $a >= 0 && $a <= 255 && $a =~ /^[0-9]+$/;
792 croak "Bad ending address" unless $b >= 0 && $b <= 8 && $b =~ /^[0-9]+$/;
793
794 my $n= 1 << (8-$b);
795
796 $a &= ($n-1) ^ 255;
797
798 push @r, $a;
799 push @r, $a + ($n-1);
800 }
801 return @r;
802}
803
804sub _ipcmp {
805 my $aa=shift;
806 my $bb=shift;
807
808 my $isipv6_1;
809 my $isipv6_2;
810
811 ($isipv6_1, $aa)=_ipv6to4($aa);
812 ($isipv6_2, $bb)=_ipv6to4($bb);
813
814 my @a=split (/\./, $aa);
815 my @b=split (/\./, $bb);
816
817 unshift @a, (0,0,0,0,0,0,0,0,0,0,255,255)
818 unless $isipv6_1;
819
820 unshift @b, (0,0,0,0,0,0,0,0,0,0,255,255)
821 unless $isipv6_2;
822
823 croak "Different number of octets in IP addresses" unless $#a == $#b;
824
825 while ($#a >= 0 && $a[0] == $b[0])
826 {
827 shift @a;
828 shift @b;
829 }
830
831 return 0 if $#a < 0;
832
833 return $a[0] <=> $b[0];
834}
835
836
837=pod
838
839=head2 @octet_list=Net::CIDR::cidr2octets(@cidr_list);
840
841cidr2octets() takes @cidr_list and returns a list of leading octets
842representing those netblocks. Example:
843
844 @octet_list=Net::CIDR::cidr2octets("10.0.0.0/14", "192.168.0.0/24");
845
846The result is the following five-element array:
847("10.0", "10.1", "10.2", "10.3", "192.168.0").
848
849For IPv6 addresses, the hexadecimal words in the resulting list are
850zero-padded:
851
852 @octet_list=Net::CIDR::cidr2octets("::dead:beef:0:0/110");
853
854The result is a four-element array:
855("0000:0000:0000:0000:dead:beef:0000",
856"0000:0000:0000:0000:dead:beef:0001",
857"0000:0000:0000:0000:dead:beef:0002",
858"0000:0000:0000:0000:dead:beef:0003").
859Prefixes of IPv6 CIDR blocks should be even multiples of 16 bits, otherwise
860they can potentially expand out to a 32,768-element array, each!
861
862=cut
863
864sub cidr2octets {
865 my @cidr=@_;
866
867 my @r;
868
869 while ($#cidr >= 0)
870 {
871 my $cidr=shift @cidr;
872
873 $cidr =~ s/\s//g;
874
875 croak "CIDR doesn't look like a CIDR\n" unless ($cidr =~ /(.*)\/(.*)/);
876
877 my ($ip, $pfix)=($1, $2);
878
879 my $isipv6;
880
881 my @ips=_iptoipa($ip);
882
883 $isipv6=shift @ips;
884
885 croak "$pfix, as in '$cidr', does not make sense"
886 unless $pfix >= 0 && $pfix <= ($#ips+1) * 8 && $pfix =~ /^[0-9]+$/;
887
888 my $i;
889
890 for ($i=0; $i <= $#ips; $i++)
891 {
892 last if $pfix - $i * 8 < 8;
893 }
894
895 my @msb=splice @ips, 0, $i;
896
897 my $bitsleft= $pfix - $i * 8;
898
899 if ($#ips < 0 || $bitsleft == 0)
900 {
901 if ($pfix == 0 && $bitsleft == 0)
902 {
903 foreach (0..255)
904 {
905 my @n=($_);
906
907 if ($isipv6)
908 {
909 _push_ipv6_octets(\@r, \@n);
910 }
911 else
912 {
913 push @r, $n[0];
914 }
915 }
916 }
917 elsif ($isipv6)
918 {
919 _push_ipv6_octets(\@r, \@msb);
920 }
921 else
922 {
923 push @r, join(".", @msb);
924 }
925 next;
926 }
927
928 my @rr=_cidr2range8(($ips[0], $bitsleft));
929
930 while ($#rr >= 0)
931 {
932 my $a=shift @rr;
933 my $b=shift @rr;
934
935 grep {
936 if ($isipv6)
937 {
938 push @msb, $_;
939 _push_ipv6_octets(\@r, \@msb);
940 pop @msb;
941 }
942 else
943 {
944 push @r, join(".", (@msb, $_));
945 }
946 } ($a .. $b);
947 }
948 }
949
950 return @r;
951}
952
953sub _push_ipv6_octets {
954 my $ary_ref=shift;
955 my $octets=shift;
956
957 if ( ($#{$octets} % 2) == 0) # Odd number of octets
958 {
959 foreach (0 .. 255)
960 {
961 push @$octets, $_;
962 _push_ipv6_octets($ary_ref, $octets);
963 pop @$octets;
964 }
965 return;
966 }
967
968 my $i;
969 my $s="";
970
971 for ($i=0; $i <= $#{$octets}; $i += 2)
972 {
973 $s .= ":" if $s ne "";
974 $s .= sprintf("%02x%02x", $$octets[$i], $$octets[$i+1]);
975 }
976 push @$ary_ref, $s;
977}
978
979=pod
980
981=head2 @cidr_list=Net::CIDR::cidradd($block, @cidr_list);
982
983The cidradd() functions allows a CIDR list to be built one CIDR netblock
984at a time, merging adjacent and overlapping ranges.
985$block is a single netblock, expressed as either "start-finish", or
986"address/prefix".
987Example:
988
989 @cidr_list=Net::CIDR::range2cidr("192.168.0.0-192.168.0.255");
990 @cidr_list=Net::CIDR::cidradd("10.0.0.0/8", @cidr_list);
991 @cidr_list=Net::CIDR::cidradd("192.168.1.0-192.168.1.255", @cidr_list);
992
993The result is a two-element array: ("10.0.0.0/8", "192.168.0.0/23").
994IPv6 addresses are handled in an analogous fashion.
995
996=cut
997
998sub cidradd {
999 my @cidr=@_;
1000
1001 my $ip=shift @cidr;
1002
1003 $ip="$ip-$ip" unless $ip =~ /[-\/]/;
1004
1005 unshift @cidr, $ip;
1006
1007 @cidr=cidr2range(@cidr);
1008
1009 my @a;
1010 my @b;
1011
1012 grep {
1013 croak "This doesn't look like start-end\n" unless /(.*)-(.*)/;
1014 push @a, $1;
1015 push @b, $2;
1016 } @cidr;
1017
1018 my $lo=shift @a;
1019 my $hi=shift @b;
1020
1021 my $i;
1022
1023 for ($i=0; $i <= $#a; $i++)
1024 {
1025 last if _ipcmp($lo, $hi) > 0;
1026
1027 next if _ipcmp($b[$i], $lo) < 0;
1028 next if _ipcmp($hi, $a[$i]) < 0;
1029
1030 if (_ipcmp($a[$i],$lo) <= 0 && _ipcmp($hi, $b[$i]) <= 0)
1031 {
1032 $lo=_add1($hi);
1033 last;
1034 }
1035
1036 if (_ipcmp($a[$i],$lo) <= 0)
1037 {
1038 $lo=_add1($b[$i]);
1039 next;
1040 }
1041
1042 if (_ipcmp($hi, $b[$i]) <= 0)
1043 {
1044 $hi=_sub1($a[$i]);
1045 next;
1046 }
1047
1048 $a[$i]=undef;
1049 $b[$i]=undef;
1050 }
1051
1052 unless ((! defined $lo) || (! defined $hi) || _ipcmp($lo, $hi) > 0)
1053 {
1054 push @a, $lo;
1055 push @b, $hi;
1056 }
1057
1058 @cidr=();
1059
1060 @a=grep ( (defined $_), @a);
1061 @b=grep ( (defined $_), @b);
1062
1063 for ($i=0; $i <= $#a; $i++)
1064 {
1065 push @cidr, "$a[$i]-$b[$i]";
1066 }
1067
1068 @cidr=sort {
1069 $a =~ /(.*)-/;
1070
1071 my $c=$1;
1072
1073 $b =~ /(.*)-/;
1074
1075 my $d=$1;
1076
1077 my $e=_ipcmp($c, $d);
1078 return $e;
1079 } @cidr;
1080
1081 $i=0;
1082
1083 while ($i < $#cidr)
1084 {
1085 $cidr[$i] =~ /(.*)-(.*)/;
1086
1087 my ($k, $l)=($1, $2);
1088
1089 $cidr[$i+1] =~ /(.*)-(.*)/;
1090
1091 my ($m, $n)=($1, $2);
1092
1093 if (_ipcmp( _add1($l), $m) == 0)
1094 {
1095 splice @cidr, $i, 2, "$k-$n";
1096 next;
1097 }
1098 ++$i;
1099 }
1100
1101 return range2cidr(@cidr);
1102}
1103
1104
1105sub _add1 {
1106 my $n=shift;
1107
1108 my $isipv6;
1109
1110 ($isipv6, $n)=_ipv6to4($n);
1111
1112 my @ip=split(/\./, $n);
1113
1114 my $i=$#ip;
1115
1116 while ($i >= 0)
1117 {
1118 last if ++$ip[$i] < 256;
1119 $ip[$i]=0;
1120 --$i;
1121 }
1122
1123 return undef if $i < 0;
1124
1125 $i=join(".", @ip);
1126 $i=_ipv4to6($i) if $isipv6;
1127 return $i;
1128
1129}
1130
1131sub _sub1 {
1132 my $n=shift;
1133
1134 my $isipv6;
1135
1136 ($isipv6, $n)=_ipv6to4($n);
1137
1138 my @ip=split(/\./, $n);
1139
1140 my $i=$#ip;
1141
1142 while ($i >= 0)
1143 {
1144 last if --$ip[$i] >= 0;
1145 $ip[$i]=255;
1146 --$i;
1147 }
1148
1149 return undef if $i < 0;
1150
1151 $i=join(".", @ip);
1152 $i=_ipv4to6($i) if $isipv6;
1153 return $i;
1154}
1155
1156=pod
1157
1158=head2 $found=Net::CIDR::cidrlookup($ip, @cidr_list);
1159
1160Search for $ip in @cidr_list. $ip can be a single IP address, or a
1161netblock in CIDR or start-finish notation.
1162lookup() returns 1 if $ip overlaps any netblock in @cidr_list, 0 if not.
1163
1164=cut
1165
1166sub cidrlookup {
1167 my @cidr=@_;
1168
1169 my $ip=shift @cidr;
1170
1171 $ip="$ip-$ip" unless $ip =~ /[-\/]/;
1172
1173 unshift @cidr, $ip;
1174
1175 @cidr=cidr2range(@cidr);
1176
1177 my @a;
1178 my @b;
1179
1180 grep {
1181 croak "This doesn't look like start-end\n" unless /(.*)-(.*)/;
1182 push @a, $1;
1183 push @b, $2;
1184 } @cidr;
1185
1186 my $lo=shift @a;
1187 my $hi=shift @b;
1188
1189 my $i;
1190
1191 for ($i=0; $i <= $#a; $i++)
1192 {
1193 next if _ipcmp($b[$i], $lo) < 0;
1194 next if _ipcmp($hi, $a[$i]) < 0;
1195 return 1;
1196 }
1197
1198 return 0;
1199}
1200
1201=pod
1202
1203=head2 $ip=Net::CIDR::cidrvalidate($ip);
1204
1205Validate whether $ip is a valid IPv4 or IPv6 address, or a CIDR.
1206Returns its argument or undef.
1207Spaces are removed, and IPv6 hexadecimal address are converted to lowercase.
1208
1209$ip with less than four octets gets filled out with additional octets, and
1210the modified value gets returned. This turns "192.168/16" into a proper
1211"192.168.0.0/16".
1212
1213If $ip contains a "/", it must be a valid CIDR, otherwise it must be a valid
1214IPv4 or an IPv6 address.
1215
1216A technically invalid CIDR, such as "192.168.0.1/24" fails validation, returning
1217undef.
1218
1219=cut
1220
1221sub cidrvalidate {
1222 my $v=shift;
1223
1224 $v =~ s/\s//g;
1225
1226 $v=lc($v);
1227
1228 my $suffix;
1229
1230 ($v, $suffix)=($1, $2) if $v =~ m@(.*)/(.*)@;
1231
1232 if (defined $suffix)
1233 {
1234 return undef unless $suffix =~ /^\d+$/ &&
1235 ($suffix eq "0" || $suffix =~ /^[123456789]/);
1236 }
1237
1238 if ($v =~ /^([0-9\.]+)$/ || $v =~ /^::ffff:([0-9\.]+)$/ ||
1239 $v =~ /^:([0-9\.]+)$/)
1240 {
1241 my $n=$1;
1242
1243 return undef if $n =~ /^\./ || $n =~ /\.$/ || $n =~ /\.\./;
1244
1245 my @o= split(/\./, $n);
1246
1247 while ($#o < 3)
1248 {
1249 push @o, "0";
1250 }
1251
1252 $n=join(".", @o);
1253
1254 return undef if $#o != 3;
1255
1256 foreach (@o)
1257 {
1258 return undef if /^0./;
1259 return undef if $_ < 0 || $_ > 255;
1260 }
1261
1262 if ($v =~ /^::ffff/)
1263 {
1264 $suffix=128 unless defined $suffix;
1265
1266 return undef if $suffix < 128-32;
1267
1268 $suffix -= 128-32;
1269 }
1270 else
1271 {
1272 $suffix=32 unless defined $suffix;
1273 }
1274
1275 foreach (addr2cidr($n))
1276 {
1277 return $_ if $_ eq "$n/$suffix";
1278 }
1279 return undef;
1280 }
1281
1282 return undef unless $v =~ /^[0-9a-f:]+$/;
1283
1284 return undef if $v =~ /:::/ || $v =~ /^:[^:]/ || $v =~ /[^:]:$/
1285 || $v =~ /::.*::/;
1286
1287 my @o=grep (/./, split(/:/, $v));
1288
1289 return undef if ($#o >= 8 || ($#o<7 && $v !~ /::/));
1290
1291 foreach (@o)
1292 {
1293 return undef if length ($_) > 4;
1294 }
1295
1296 $suffix=128 unless defined $suffix;
1297
1298 $v =~ s/([0-9A-Fa-f]+)/_triml0($1)/ge;
1299
1300 foreach (addr2cidr($v))
1301 {
1302 return $_ if $_ eq "$v/$suffix";
1303 }
1304 return undef;
1305}
1306
1307sub _triml0 {
1308 my ($a) = @_;
1309
1310 $a =~ s/^0+//g;
1311 $a = "0" if $a eq '';
1312 return $a
1313}
1314
1315=pod
1316
1317=head1 BUGS
1318
1319Garbage in, garbage out.
1320Always use cidrvalidate() before doing anything with untrusted input.
1321Otherwise,
1322"slightly" invalid input will work (extraneous whitespace
1323is generally OK),
1324but the functions will croak if you're totally off the wall.
1325
1326=head1 AUTHOR
1327
1328Sam Varshavchik <sam@email-scan.com>
1329
1330With some contributions from David Cantrell <david@cantrell.org.uk>
1331
1332=cut
1333
1334__END__