File Coverage

blib/lib/NetAddr/IP/Lite.pm
Criterion Covered Total %
statement 192 396 48.4
branch 130 308 42.2
condition 56 224 25.0
subroutine 37 67 55.2
pod 28 37 75.6
total 443 1032 42.9


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2              
3             package NetAddr::IP::Lite;
4              
5 32     32   121 use Carp;
  32         40  
  32         1608  
6 32     32   129 use strict;
  32         45  
  32         778  
7             #use diagnostics;
8             #use warnings;
9 32         208 use NetAddr::IP::InetBase qw(
10             inet_any2n
11             isIPv4
12             inet_n2dx
13             inet_aton
14             ipv6_aton
15             ipv6_n2x
16             fillIPv4
17 32     32   13838 );
  32         53  
18 32         137 use NetAddr::IP::Util qw(
19             addconst
20             sub128
21             ipv6to4
22             notcontiguous
23             shiftleft
24             hasbits
25             bin2bcd
26             bcd2bin
27             mask4to6
28             ipv4to6
29             naip_gethostbyname
30             havegethostbyname2
31 32     32   14177 );
  32         59  
32              
33 32     32   148 use vars qw(@ISA @EXPORT_OK $VERSION $Accept_Binary_IP $Old_nth $NoFQDN $AUTOLOAD *Zero);
  32         47  
  32         6188  
34              
35             $VERSION = do { my @r = (q$Revision: 1.57 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
36              
37             require Exporter;
38              
39             @ISA = qw(Exporter);
40              
41             @EXPORT_OK = qw(Zeros Zero Ones V4mask V4net);
42              
43             # Set to true, to enable recognizing of ipV4 && ipV6 binary notation IP
44             # addresses. Thanks to Steve Snodgrass for reporting. This can be done
45             # at the time of use-ing the module. See docs for details.
46              
47             $Accept_Binary_IP = 0;
48             $Old_nth = 0;
49             *Zero = \&Zeros;
50              
51             =pod
52              
53             =encoding UTF-8
54              
55             =head1 NAME
56              
57             NetAddr::IP::Lite - Manages IPv4 and IPv6 addresses and subnets
58              
59             =head1 SYNOPSIS
60              
61             use NetAddr::IP::Lite qw(
62             Zeros
63             Ones
64             V4mask
65             V4net
66             :aton DEPRECATED !
67             :old_nth
68             :upper
69             :lower
70             :nofqdn
71             );
72              
73             my $ip = new NetAddr::IP::Lite '127.0.0.1';
74             or if your prefer
75             my $ip = NetAddr::IP::Lite->new('127.0.0.1);
76             or from a packed IPv4 address
77             my $ip = new_from_aton NetAddr::IP::Lite (inet_aton('127.0.0.1'));
78             or from an octal filtered IPv4 address
79             my $ip = new_no NetAddr::IP::Lite '127.012.0.0';
80              
81             print "The address is ", $ip->addr, " with mask ", $ip->mask, "\n" ;
82              
83             if ($ip->within(new NetAddr::IP::Lite "127.0.0.0", "255.0.0.0")) {
84             print "Is a loopback address\n";
85             }
86              
87             # This prints 127.0.0.1/32
88             print "You can also say $ip...\n";
89              
90             The following four functions return ipV6 representations of:
91              
92             :: = Zeros();
93             FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF = Ones();
94             FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:: = V4mask();
95             ::FFFF:FFFF = V4net();
96              
97             Will also return an ipV4 or ipV6 representation of a
98             resolvable Fully Qualified Domanin Name (FQDN).
99              
100             =head1 INSTALLATION
101              
102             Un-tar the distribution in an appropriate directory and type:
103              
104             perl Makefile.PL
105             make
106             make test
107             make install
108              
109             B depends on B which installs by default with its primary functions compiled
110             using Perl's XS extensions to build a 'C' library. If you do not have a 'C'
111             complier available or would like the slower Pure Perl version for some other
112             reason, then type:
113              
114             perl Makefile.PL -noxs
115             make
116             make test
117             make install
118              
119             =head1 DESCRIPTION
120              
121             This module provides an object-oriented abstraction on top of IP
122             addresses or IP subnets, that allows for easy manipulations. Most of the
123             operations of NetAddr::IP are supported. This module will work with older
124             versions of Perl and is compatible with Math::BigInt.
125              
126             * By default B functions and methods return string IPv6
127             addresses in uppercase. To change that to lowercase:
128              
129             NOTE: the AUGUST 2010 RFC5952 states:
130              
131             4.3. Lowercase
132              
133             The characters "a", "b", "c", "d", "e", and "f" in an IPv6
134             address MUST be represented in lowercase.
135              
136             It is recommended that all NEW applications using NetAddr::IP::Lite be
137             invoked as shown on the next line.
138              
139             use NetAddr::IP::Lite qw(:lower);
140              
141             * To ensure the current IPv6 string case behavior even if the default changes:
142              
143             use NetAddr::IP::Lite qw(:upper);
144              
145              
146             The internal representation of all IP objects is in 128 bit IPv6 notation.
147             IPv4 and IPv6 objects may be freely mixed.
148              
149             The supported operations are described below:
150              
151             =cut
152              
153             # in the off chance that NetAddr::IP::Lite objects are created
154             # and the caller later loads NetAddr::IP and expects to use
155             # those objects, let the AUTOLOAD routine find and redirect
156             # NetAddr::IP::Lite method and subroutine calls to NetAddr::IP.
157             #
158              
159             my $parent = 'NetAddr::IP';
160              
161             # test function
162             #
163             # input: subroutine name in NetAddr::IP
164             # output: t/f if sub name exists in NetAddr::IP namespace
165             #
166             #sub sub_exists {
167             # my $other = $parent .'::';
168             # return exists ${$other}{$_[0]};
169             #}
170              
171       0     sub DESTROY {};
172              
173             sub AUTOLOAD {
174 32     32   146 no strict;
  32         36  
  32         20512  
175 0     0   0 my ($pkg,$func) = ($AUTOLOAD =~ /(.*)::([^:]+)$/);
176 0         0 my $other = $parent .'::';
177              
178 0 0 0     0 if ($pkg =~ /^$other/o && exists ${$other}{$func}) {
  0         0  
179 0         0 $other .= $func;
180 0         0 goto &{$other};
  0         0  
181             }
182              
183 0         0 my @stack = caller(0);
184              
185 0 0       0 if ( $pkg eq ref $_[0] ) {
186 0         0 $other = qq|Can't locate object method "$func" via|;
187             }
188             else {
189 0         0 $other = qq|Undefined subroutine \&$AUTOLOAD not found in|;
190             }
191 0         0 die $other . qq| package "$parent" or "$pkg" (did you forgot to load a module?) at $stack[1] line $stack[2].\n|;
192             }
193              
194             =head2 Overloaded Operators
195              
196             =cut
197              
198             # these really should be packed in Network Long order but since they are
199             # symmetrical, that extra internal processing can be skipped
200              
201             my $_v4zero = pack('L',0);
202             my $_zero = pack('L4',0,0,0,0);
203             my $_ones = ~$_zero;
204             my $_v4mask = pack('L4',0xffffffff,0xffffffff,0xffffffff,0);
205             my $_v4net = ~ $_v4mask;
206             my $_ipv4FFFF = pack('N4',0,0,0xffff,0);
207              
208             sub Zeros() {
209 290     290 0 688 return $_zero;
210             }
211             sub Ones() {
212 8906     8906 0 33181 return $_ones;
213             }
214             sub V4mask() {
215 3     3 0 36 return $_v4mask;
216             }
217             sub V4net() {
218 336     336 0 587 return $_v4net;
219             }
220              
221             #############################################
222             # These are the overload methods, placed here
223             # for convenience.
224             #############################################
225              
226             use overload
227              
228             '+' => \&plus,
229              
230             '-' => \&minus,
231              
232             '++' => \&plusplus,
233              
234             '--' => \&minusminus,
235              
236             "=" => \©,
237              
238 22260     22260   41428 '""' => sub { $_[0]->cidr(); },
239              
240             'eq' => sub {
241 533 50   533   9171 my $a = (UNIVERSAL::isa($_[0],__PACKAGE__)) ? $_[0]->cidr : $_[0];
242 533 100       2157 my $b = (UNIVERSAL::isa($_[1],__PACKAGE__)) ? $_[1]->cidr : $_[1];
243 533         1514 $a eq $b;
244             },
245              
246             'ne' => sub {
247 0 0   0   0 my $a = (UNIVERSAL::isa($_[0],__PACKAGE__)) ? $_[0]->cidr : $_[0];
248 0 0       0 my $b = (UNIVERSAL::isa($_[1],__PACKAGE__)) ? $_[1]->cidr : $_[1];
249 0         0 $a ne $b;
250             },
251              
252             '==' => sub {
253 3 50 33 3   422 return 0 unless UNIVERSAL::isa($_[0],__PACKAGE__) && UNIVERSAL::isa($_[1],__PACKAGE__);
254 3         7 $_[0]->cidr eq $_[1]->cidr;
255             },
256              
257             '!=' => sub {
258 0 0 0 0   0 return 1 unless UNIVERSAL::isa($_[0],__PACKAGE__) && UNIVERSAL::isa($_[1],__PACKAGE__);
259 0         0 $_[0]->cidr ne $_[1]->cidr;
260             },
261              
262             '>' => sub {
263 9 100   9   80 return &comp_addr_mask > 0 ? 1 : 0;
264             },
265              
266             '<' => sub {
267 8464 100   8464   11537 return &comp_addr_mask < 0 ? 1 : 0;
268             },
269              
270             '>=' => sub {
271 0 0   0   0 return &comp_addr_mask < 0 ? 0 : 1;
272             },
273              
274             '<=' => sub {
275 0 0   0   0 return &comp_addr_mask > 0 ? 0 : 1;
276             },
277              
278 32         726 '<=>' => \&comp_addr_mask,
279              
280 32     32   19974 'cmp' => \&comp_addr_mask;
  32         16384  
281              
282             sub comp_addr_mask {
283 68713     68713 0 123721 my($c,$rv) = sub128($_[0]->{addr},$_[1]->{addr});
284 68713 100       123831 return -1 unless $c;
285 3535 100       8627 return 1 if hasbits($rv);
286 199         1571 ($c,$rv) = sub128($_[0]->{mask},$_[1]->{mask});
287 199 100       764 return -1 unless $c;
288 167 100       727 return hasbits($rv) ? 1 : 0;
289             }
290              
291             #sub comp_addr {
292             # my($c,$rv) = sub128($_[0]->{addr},$_[1]->{addr});
293             # return -1 unless $c;
294             # return hasbits($rv) ? 1 : 0;
295             #}
296              
297             =pod
298              
299             =over
300              
301             =item B)>
302              
303             Has been optimized to copy one NetAddr::IP::Lite object to another very quickly.
304              
305             =item Bcopy()>>
306              
307             The B)> operation is only put in to operation when the
308             copied object is further mutated by another overloaded operation. See
309             L B for details.
310              
311             Bcopy()>> actually creates a new object when called.
312              
313             =cut
314              
315             sub copy {
316 54556     54556 1 78395 return _new($_[0],$_[0]->{addr}, $_[0]->{mask});
317             }
318              
319             =item B
320              
321             An object can be used just as a string. For instance, the following code
322              
323             my $ip = new NetAddr::IP::Lite '192.168.1.123';
324             print "$ip\n";
325              
326             Will print the string 192.168.1.123/32.
327              
328             my $ip = new6 NetAddr::IP::Lite '192.168.1.123';
329             print "$ip\n";
330              
331             Will print the string 0:0:0:0:0:0:C0A8:17B/128
332              
333             =item B
334              
335             You can test for equality with either C, C, C<==> or C. C, C allows the
336             comparison with arbitrary strings as well as NetAddr::IP::Lite objects. The
337             following example:
338              
339             if (NetAddr::IP::Lite->new('127.0.0.1','255.0.0.0') eq '127.0.0.1/8')
340             { print "Yes\n"; }
341              
342             Will print out "Yes".
343              
344             Comparison with C<==> and C requires both operands to be NetAddr::IP::Lite objects.
345              
346             =item B, E, E=, E=, E=E and C>
347              
348             Internally, all network objects are represented in 128 bit format.
349             The numeric representation of the network is compared through the
350             corresponding operation. Comparisons are tried first on the address portion
351             of the object and if that is equal then the NUMERIC cidr portion of the
352             masks are compared. This leads to the counterintuitive result that
353              
354             /24 > /16
355              
356             Comparison should not be done on netaddr objects with different CIDR as
357             this may produce indeterminate - unexpected results,
358             rather the determination of which netblock is larger or smaller should be
359             done by comparing
360              
361             $ip1->masklen <=> $ip2->masklen
362              
363             =item B)>
364              
365             Add a 32 bit signed constant to the address part of a NetAddr object.
366             This operation changes the address part to point so many hosts above the
367             current objects start address. For instance, this code:
368              
369             print NetAddr::IP::Lite->new('127.0.0.1/8') + 5;
370              
371             will output 127.0.0.6/8. The address will wrap around at the broadcast
372             back to the network address. This code:
373              
374             print NetAddr::IP::Lite->new('10.0.0.1/24') + 255;
375              
376             outputs 10.0.0.0/24.
377              
378             Returns the the unchanged object when the constant is missing or out of range.
379              
380             2147483647 <= constant >= -2147483648
381              
382             =cut
383              
384             sub plus {
385 24     24 0 1172 my $ip = shift;
386 24         17 my $const = shift;
387              
388 24 50 66     133 return $ip unless $const &&
      66        
389             $const < 2147483648 &&
390             $const > -2147483649;
391              
392 23         29 my $a = $ip->{addr};
393 23         18 my $m = $ip->{mask};
394              
395 23         32 my $lo = $a & ~$m;
396 23         25 my $hi = $a & $m;
397              
398 23         78 my $new = ((addconst($lo,$const))[1] & ~$m) | $hi;
399              
400 23         33 return _new($ip,$new,$m);
401             }
402              
403             =item B)>
404              
405             The complement of the addition of a constant.
406              
407             =item B)>
408              
409             Returns the difference between the address parts of two NetAddr::IP::Lite
410             objects address parts as a 32 bit signed number.
411              
412             Returns B if the difference is out of range.
413              
414             =cut
415              
416             my $_smsk = pack('L3N',0xffffffff,0xffffffff,0xffffffff,0x80000000);
417              
418             sub minus {
419 3     3 0 4 my $ip = shift;
420 3         3 my $arg = shift;
421 3 50       5 unless (ref $arg) {
422 3         5 return plus($ip, -$arg);
423             }
424 0         0 my($carry,$dif) = sub128($ip->{addr},$arg->{addr});
425 0 0       0 if ($carry) { # value is positive
426 0 0       0 return undef if hasbits($dif & $_smsk); # all sign bits should be 0's
427 0         0 return (unpack('L3N',$dif))[3];
428             } else {
429 0 0       0 return undef if hasbits(($dif & $_smsk) ^ $_smsk); # sign is 1's
430 0         0 return (unpack('L3N',$dif))[3] - 4294967296;
431             }
432             }
433              
434             # Auto-increment an object
435              
436             =item B
437              
438             Auto-incrementing a NetAddr::IP::Lite object causes the address part to be
439             adjusted to the next host address within the subnet. It will wrap at
440             the broadcast address and start again from the network address.
441              
442             =cut
443              
444             sub plusplus {
445 8333     8333 0 2321213 my $ip = shift;
446              
447 8333         14308 my $a = $ip->{addr};
448 8333         10983 my $m = $ip->{mask};
449              
450 8333         13666 my $lo = $a & ~ $m;
451 8333         7790 my $hi = $a & $m;
452              
453 8333         33040 $ip->{addr} = ((addconst($lo,1))[1] & ~ $m) | $hi;
454 8333         44204 return $ip;
455             }
456              
457             =item B
458              
459             Auto-decrementing a NetAddr::IP::Lite object performs exactly the opposite
460             of auto-incrementing it, as you would expect.
461              
462             =cut
463              
464             sub minusminus {
465 0     0 0 0 my $ip = shift;
466              
467 0         0 my $a = $ip->{addr};
468 0         0 my $m = $ip->{mask};
469              
470 0         0 my $lo = $a & ~$m;
471 0         0 my $hi = $a & $m;
472              
473 0         0 $ip->{addr} = ((addconst($lo,-1))[1] & ~$m) | $hi;
474 0         0 return $ip;
475             }
476              
477             #############################################
478             # End of the overload methods.
479             #############################################
480              
481             # Preloaded methods go here.
482              
483             # This is a variant to ->new() that
484             # creates and blesses a new object
485             # without the fancy parsing of
486             # IP formats and shorthands.
487              
488             # return a blessed IP object without parsing
489             # input: prototype, naddr, nmask
490             # returns: blessed IP object
491             #
492             sub _new ($$$) {
493 150298     150298   124614 my $proto = shift;
494 150298   50     233434 my $class = ref($proto) || die "reference required";
495 150298         147936 $proto = $proto->{isv6};
496 150298         258609 my $self = {
497             addr => $_[0],
498             mask => $_[1],
499             isv6 => $proto,
500             };
501 150298         2230171 return bless $self, $class;
502             }
503              
504             =pod
505              
506             =back
507              
508             =head2 Methods
509              
510             =over
511              
512             =item C<-Enew([$addr, [ $mask|IPv6 ]])>
513              
514             =item C<-Enew6([$addr, [ $mask]])>
515              
516             =item C<-Enew6FFFF([$addr, [ $mask]])>
517              
518             =item C<-Enew_no([$addr, [ $mask]])>
519              
520             =item C<-Enew_from_aton($netaddr)>
521              
522             =item new_cis and new_cis6 are DEPRECATED
523              
524             =item C<-Enew_cis("$addr $mask)>
525              
526             =item C<-Enew_cis6("$addr $mask)>
527              
528             The first three methods create a new address with the supplied address in
529             C<$addr> and an optional netmask C<$mask>, which can be omitted to get
530             a /32 or /128 netmask for IPv4 / IPv6 addresses respectively.
531              
532             new6FFFF specifically returns an IPv4 address in IPv6 format according to RFC4291
533              
534             new6 ::xxxx:xxxx
535             new6FFFF ::FFFF:xxxx:xxxx
536              
537             The third method C is exclusively for IPv4 addresses and filters
538             improperly formatted
539             dot quad strings for leading 0's that would normally be interpreted as octal
540             format by NetAddr per the specifications for inet_aton.
541              
542             B takes a packed IPv4 address and assumes a /32 mask. This
543             function replaces the DEPRECATED :aton functionality which is fundamentally
544             broken.
545              
546             The last two methods B and B differ from B and
547             B only in that they except the common Cisco address notation for
548             address/mask pairs with a B as a separator instead of a slash (/)
549              
550             These methods are DEPRECATED because the functionality is now included
551             in the other "new" methods
552              
553             i.e. ->new_cis('1.2.3.0 24')
554             or
555             ->new_cis6('::1.2.3.0 120')
556              
557             C<-Enew6> and
558             C<-Enew_cis6> mark the address as being in ipV6 address space even
559             if the format would suggest otherwise.
560              
561             i.e. ->new6('1.2.3.4') will result in ::102:304
562              
563             addresses submitted to ->new in ipV6 notation will
564             remain in that notation permanently. i.e.
565             ->new('::1.2.3.4') will result in ::102:304
566             whereas new('1.2.3.4') would print out as 1.2.3.4
567              
568             See "STRINGIFICATION" below.
569              
570             C<$addr> can be almost anything that can be resolved to an IP address
571             in all the notations I have seen over time. It can optionally contain
572             the mask in CIDR notation. If the OPTIONAL perl module Socket6 is
573             available in the local library it will autoload and ipV6 host6
574             names will be resolved as well as ipV4 hostnames.
575              
576             B notation is understood, with the limitation that the range
577             specified by the prefix must match with a valid subnet.
578              
579             Addresses in the same format returned by C or
580             C can also be understood, although no mask can be
581             specified for them. The default is to not attempt to recognize this
582             format, as it seems to be seldom used.
583              
584             ###### DEPRECATED, will be remove in version 5 ############
585             To accept addresses in that format, invoke the module as in
586              
587             use NetAddr::IP::Lite ':aton'
588              
589             ###### USE new_from_aton instead ##########################
590              
591             If called with no arguments, 'default' is assumed.
592              
593             If called with an empty string as the argument, returns 'undef'
594              
595             C<$addr> can be any of the following and possibly more...
596              
597             n.n
598             n.n/mm
599             n.n mm
600             n.n.n
601             n.n.n/mm
602             n.n.n mm
603             n.n.n.n
604             n.n.n.n/mm 32 bit cidr notation
605             n.n.n.n mm
606             n.n.n.n/m.m.m.m
607             n.n.n.n m.m.m.m
608             loopback, localhost, broadcast, any, default
609             x.x.x.x/host
610             0xABCDEF, 0b111111000101011110, (or a bcd number)
611             a netaddr as returned by 'inet_aton'
612              
613              
614             Any RFC1884 notation
615              
616             ::n.n.n.n
617             ::n.n.n.n/mmm 128 bit cidr notation
618             ::n.n.n.n/::m.m.m.m
619             ::x:x
620             ::x:x/mmm
621             x:x:x:x:x:x:x:x
622             x:x:x:x:x:x:x:x/mmm
623             x:x:x:x:x:x:x:x/m:m:m:m:m:m:m:m any RFC1884 notation
624             loopback, localhost, unspecified, any, default
625             ::x:x/host
626             0xABCDEF, 0b111111000101011110 within the limits
627             of perl's number resolution
628             123456789012 a 'big' bcd number (bigger than perl likes)
629             and Math::BigInt
630              
631             A Fully Qualified Domain Name which returns an ipV4 address or an ipV6
632             address, embodied in that order. This previously undocumented feature
633             may be disabled with:
634              
635             use NetAddr::IP::Lite ':nofqdn';
636              
637             If called with no arguments, 'default' is assumed.
638              
639             If called with and empty string as the argument, 'undef' is returned;
640              
641             =cut
642              
643             my $lbmask = inet_aton('255.0.0.0');
644             my $_p4broad = inet_any2n('255.255.255.255');
645             my $_p4loop = inet_any2n('127.0.0.1');
646             my $_p4mloop = inet_aton('255.0.0.0');
647             $_p4mloop = mask4to6($_p4mloop);
648             my $_p6loop = inet_any2n('::1');
649              
650             my %fip4 = (
651             default => Zeros,
652             any => Zeros,
653             broadcast => $_p4broad,
654             loopback => $_p4loop,
655             unspecified => undef,
656             );
657             my %fip4m = (
658             default => Zeros,
659             any => Zeros,
660             broadcast => Ones,
661             loopback => $_p4mloop,
662             unspecified => undef, # not applicable for ipV4
663             host => Ones,
664             );
665              
666             my %fip6 = (
667             default => Zeros,
668             any => Zeros,
669             broadcast => undef, # not applicable for ipV6
670             loopback => $_p6loop,
671             unspecified => Zeros,
672             );
673              
674             my %fip6m = (
675             default => Zeros,
676             any => Zeros,
677             broadcast => undef, # not applicable for ipV6
678             loopback => Ones,
679             unspecified => Ones,
680             host => Ones,
681             );
682              
683             my $ff000000 = pack('L3N',0xffffffff,0xffffffff,0xffffffff,0xFF000000);
684             my $ffff0000 = pack('L3N',0xffffffff,0xffffffff,0xffffffff,0xFFFF0000);
685             my $ffffff00 = pack('L3N',0xffffffff,0xffffffff,0xffffffff,0xFFFFFF00);
686              
687             sub _obits ($$) {
688 5     5   9 my($lo,$hi) = @_;
689              
690 5 50       10 return 0xFF if $lo == $hi;
691 5         24 return (~ ($hi ^ $lo)) & 0xFF;
692             }
693              
694             sub new_no($;$$) {
695 0     0 1 0 unshift @_, -1;
696 0         0 goto &_xnew;
697             }
698              
699             sub new($;$$) {
700 7435     7435 1 108001 unshift @_, 0;
701 7435         15397 goto &_xnew;
702             }
703              
704             sub new_from_aton($$) {
705 0     0 1 0 my $proto = shift;
706 0   0     0 my $class = ref $proto || $proto || __PACKAGE__;
707 0         0 my $ip = shift;
708 0 0       0 return undef unless defined $ip;
709 0         0 my $addrlen = length($ip);
710 0 0       0 return undef unless $addrlen == 4;
711 0         0 my $self = {
712             addr => ipv4to6($ip),
713             mask => &Ones,
714             isv6 => 0,
715             };
716 0         0 return bless $self, $class;
717             }
718              
719             sub new6($;$$) {
720 0     0 1 0 unshift @_, 1;
721 0         0 goto &_xnew;
722             }
723              
724             sub new6FFFF($;$$) {
725 0     0 1 0 my $ip = _xnew(1,@_);
726 0         0 $ip->{addr} |= $_ipv4FFFF;
727 0         0 return $ip;
728             }
729              
730             sub new_cis($;$$) {
731 0     0 1 0 my @in = @_;
732 0 0 0     0 if ( $in[1] && $in[1] =~ m!^(.+)\s+(.+)$! ) {
733 0         0 $in[1] = $1 .'/'. $2;
734             }
735 0         0 @_ = (0,@in);
736 0         0 goto &_xnew;
737             }
738              
739             sub new_cis6($;$$) {
740 0     0 1 0 my @in = @_;
741 0 0 0     0 if ( $in[1] && $in[1] =~ m!^(.+)\s+(.+)$! ) {
742 0         0 $in[1] = $1 .'/'. $2;
743             }
744 0         0 @_ = (1,@in);
745 0         0 goto &_xnew;
746             }
747              
748             sub _no_octal {
749             # $_[0] =~ m/^(\d+)\.(\d+)\.(\d+)\.(\d+)$/;
750             # return sprintf("%d.%d.%d.%d",$1,$2,$3,$4);
751 0     0   0 (my $rv = $_[0]) =~ s#\b0*([1-9]\d*/?|0/?)#$1#g; # suppress leading zeros
752 0         0 $rv;
753             }
754              
755             sub _xnew($$;$$) {
756 7435     7435   6549 my $noctal = 0;
757 7435         7481 my $isV6 = shift;
758 7435 50       12438 if ($isV6 < 0) { # flag for no octal?
759 0         0 $isV6 = 0;
760 0         0 $noctal = 1;
761             }
762 7435         7315 my $proto = shift;
763 7435   50     27768 my $class = ref $proto || $proto || __PACKAGE__;
764 7435         6538 my $ip = shift;
765              
766 7435 50 33     23597 if ($ip && $noctal && $ip !~ m|(?:[^\s0123456789/. -])|) { # octal suppression required if not an IPv4 address
      33        
767 0         0 $ip = _no_octal($ip);
768             }
769              
770             # fix for bug #75976
771 7435 50 33     23178 return undef if defined $ip && $ip eq '';
772              
773 7435 50       10165 $ip = 'default' unless defined $ip;
774 7435 50 33     13218 $ip = _retMBIstring($ip) # treat as big bcd string
775             if ref $ip && ref $ip eq 'Math::BigInt'; # can /CIDR notation
776 7435         5692 my $hasmask = 1;
777 7435         5438 my($mask,$tmp);
778              
779             # IP to lower case AFTER ref test for Math::BigInt. 'lc' strips blessing
780              
781 7435         9434 $ip = lc $ip;
782              
783 7435         5948 while (1) {
784             # process IP's with no CIDR or that have the CIDR as part of the IP argument string
785 7435 100       11921 unless (@_) {
    50          
786             # if ($ip =~ m!^(.+)/(.+)$!) {
787 6897 50 66     40062 if ($ip !~ /\D/) { # binary number notation
    100          
    100          
788 0         0 $ip = bcd2bin($ip);
789 0         0 $mask = Ones;
790 0         0 last;
791             }
792             elsif ($ip =~ m!^([a-z0-9.:-]+)(?:/|\s+)([a-z0-9.:-]+)$! ||
793             $ip =~ m!^[\[]{1}([a-z0-9.:-]+)(?:/|\s+)([a-z0-9.:-]+)[\]]{1}$!) {
794 5874         9416 $ip = $1;
795 5874         7724 $mask = $2;
796             } elsif (grep($ip eq $_,(qw(default any broadcast loopback unspecified)))) {
797 9 50       16 $isV6 = 1 if $ip eq 'unspecified';
798 9 50       15 if ($isV6) {
799 0         0 $mask = $fip6m{$ip};
800 0 0       0 return undef unless defined ($ip = $fip6{$ip});
801             } else {
802 9         19 $mask = $fip4m{$ip};
803 9 50       24 return undef unless defined ($ip = $fip4{$ip});
804             }
805 9         13 last;
806             }
807             }
808             # process "ipv6" token and default IP's
809             elsif (defined $_[0]) {
810 538 50 33     1672 if ($_[0] =~ /ipv6/i || $isV6) {
811 0 0       0 if (grep($ip eq $_,(qw(default any loopback unspecified)))) {
812 0         0 $mask = $fip6m{$ip};
813 0         0 $ip = $fip6{$ip};
814 0         0 last;
815             } else {
816 0 0       0 return undef unless $isV6;
817             # add for ipv6 notation "12345, 1"
818             }
819             # $mask = lc $_[0];
820             # } else {
821             # $mask = lc $_[0];
822             }
823             # extract mask
824 538         543 $mask = $_[0];
825             }
826             ###
827             ### process mask
828 7426 100       11612 unless (defined $mask) {
829 1014         914 $hasmask = 0;
830 1014         919 $mask = 'host';
831             }
832              
833             # two kinds of IP's can turn on the isV6 flag
834             # 1) big digits that are over the IPv4 boundry
835             # 2) IPv6 IP syntax
836             #
837             # check these conditions and set isV6 as appropriate
838             #
839 7426         5227 my $try;
840 7426 100 33     43992 $isV6 = 1 if # check big bcd and IPv6 rfc1884
      66        
      33        
      33        
      100        
      33        
841             ( $ip !~ /\D/ && # ip is all decimal
842             (length($ip) > 3 || $ip > 255) && # exclude a single digit in the range of zero to 255, could be funny IPv4
843             ($try = bcd2bin($ip)) && ! isIPv4($try)) || # precedence so $try is not corrupted
844             (index($ip,':') >= 0 && ($try = ipv6_aton($ip))); # fails if not an rfc1884 address
845              
846             # if either of the above conditions is true, $try contains the NetAddr 128 bit address
847              
848             # checkfor Math::BigInt mask
849 7426 50 33     29766 $mask = _retMBIstring($mask) # treat as big bcd string
850             if ref $mask && ref $mask eq 'Math::BigInt';
851              
852             # MASK to lower case AFTER ref test for Math::BigInt, 'lc' strips blessing
853              
854 7426         7331 $mask = lc $mask;
855              
856 7426 100       14667 if ($mask !~ /\D/) { # bcd or CIDR notation
    100          
    100          
857 6399   33     21190 my $isCIDR = length($mask) < 4 && $mask < 129;
858 6399 100 33     20060 if ($isV6) {
    50          
859 169 50       193 if ($isCIDR) {
860 169         125 my($dq1,$dq2,$dq3,$dq4);
861 169 50 33     544 if ($ip =~ /^(\d+)(?:|\.(\d+)(?:|\.(\d+)(?:|\.(\d+))))$/ &&
    100 0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
862 0         0 do {$dq1 = $1;
863 0   0     0 $dq2 = $2 || 0;
864 0   0     0 $dq3 = $3 || 0;
865 0   0     0 $dq4 = $4 || 0;
866 0         0 1;
867             } &&
868             $dq1 >= 0 && $dq1 < 256 &&
869             $dq2 >= 0 && $dq2 < 256 &&
870             $dq3 >= 0 && $dq3 < 256 &&
871             $dq4 >= 0 && $dq4 < 256
872             ) { # corner condition of IPv4 with isV6
873 0         0 $ip = join('.',$dq1,$dq2,$dq3,$dq4);
874 0         0 $try = ipv4to6(inet_aton($ip));
875 0 0       0 if ($mask < 32) {
    0          
876 0         0 $mask = shiftleft(Ones,32 -$mask);
877             }
878             elsif ($mask == 32) {
879 0         0 $mask = Ones;
880             } else {
881 0         0 return undef; # undoubtably an error
882             }
883             }
884             elsif ($mask < 128) {
885 165         227 $mask = shiftleft(Ones,128 -$mask); # small cidr
886             } else {
887 4         6 $mask = Ones();
888             }
889             } else {
890 0         0 $mask = bcd2bin($mask);
891             }
892             }
893             elsif ($isCIDR && $mask < 33) { # is V4
894             # if ($ip && $noctal && $ip !~ m|(?:[^\s0123456789.])|) { # octal suppression required if not an IPv4 address
895             # $mask = _no_octal($mask);
896             # }
897 6230 100       6952 if ($mask < 32) {
    50          
898 6200         9568 $mask = shiftleft(Ones,32 -$mask);
899             }
900             elsif ( $mask == 32) {
901 30         77 $mask = Ones;
902             } else {
903 0         0 $mask = bcd2bin($mask);
904 0         0 $mask |= $_v4mask; # v4 always
905             }
906             } else { # also V4
907 0         0 $mask = bcd2bin($mask);
908 0         0 $mask |= $_v4mask;
909             }
910 6399 100       11964 if ($try) { # is a big number
911 169         129 $ip = $try;
912 169         170 last;
913             }
914             } elsif ($mask =~ m/^\d+\.\d+\.\d+\.\d+$/) { # ipv4 form of mask
915 9 50       22 $mask = _no_octal($mask) if $noctal; # filter for octal
916 9 50       26 return undef unless defined ($mask = inet_aton($mask));
917 9         31 $mask = mask4to6($mask);
918             } elsif (grep($mask eq $_,qw(default any broadcast loopback unspecified host))) {
919 1014 100 66     3020 if (index($ip,':') < 0 && ! $isV6) {
920 800 50       1603 return undef unless defined ($mask = $fip4m{$mask});
921             } else {
922 214 50       768 return undef unless defined ($mask = $fip6m{$mask});
923             }
924             } else {
925 4 100       100 return undef unless defined ($mask = ipv6_aton($mask)); # try ipv6 form of mask
926             }
927              
928             # process remaining IP's
929              
930 7255 100       10746 if (index($ip,':') < 0) { # ipv4 address
931 7039 100 66     22541 if ($ip =~ m/^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) {
    50 66        
    100 33        
    100 33        
    100 0        
    50 33        
    50 0        
    50 0        
    50 33        
    100 33        
    50 33        
    100 66        
    100 66        
    100 66        
    100 33        
    50 33        
    50 33        
    50 33        
    0 33        
    0 33        
      0        
      0        
      0        
      0        
932             ; # the common case
933             }
934             elsif (grep($ip eq $_,(qw(default any broadcast loopback)))) {
935 0 0       0 return undef unless defined ($ip = $fip4{$ip});
936 0         0 last;
937             }
938             elsif ($ip =~ m/^(\d+)\.(\d+)$/) {
939 4 50       35 $ip = ($hasmask)
940             ? "${1}.${2}.0.0"
941             : "${1}.0.0.${2}";
942             }
943             elsif ($ip =~ m/^(\d+)\.(\d+)\.(\d+)$/) {
944 2 50       13 $ip = ($hasmask)
945             ? "${1}.${2}.${3}.0"
946             : "${1}.${2}.0.${3}";
947             }
948             elsif ($ip =~ /^(\d+)$/ && $hasmask && $1 >= 0 and $1 < 256) { # pure numeric
949 32         268 $ip = sprintf("%d.0.0.0",$1);
950             }
951             # elsif ($ip =~ /^\d+$/ && !$hasmask) { # a big integer
952             elsif ($ip =~ /^\d+$/ ) { # a big integer
953 0         0 $ip = bcd2bin($ip);
954 0         0 last;
955             }
956             # these next three might be broken??? but they have been in the code a long time and no one has complained
957             elsif ($ip =~ /^0[xb]\d+$/ && $hasmask &&
958             (($tmp = eval "$ip") || 1) &&
959             $tmp >= 0 && $tmp < 256) {
960 0         0 $ip = sprintf("%d.0.0.0",$tmp);
961             }
962             elsif ($ip =~ /^-?\d+$/) {
963 0 0       0 $ip += 2 ** 32 if $ip < 0;
964 0         0 $ip = pack('L3N',0,0,0,$ip);
965 0         0 last;
966             }
967             elsif ($ip =~ /^-?0[xb]\d+$/) {
968 0         0 $ip = eval "$ip";
969 0         0 $ip = pack('L3N',0,0,0,$ip);
970 0         0 last;
971             }
972              
973             # notations below include an implicit mask specification
974              
975             elsif ($ip =~ m/^(\d+)\.$/) {
976 1         3 $ip = "${1}.0.0.0";
977 1         3 $mask = $ff000000;
978             }
979             elsif ($ip =~ m/^(\d+)\.(\d+)-(\d+)\.?$/ && $2 <= $3 && $3 < 256) {
980 0         0 $ip = "${1}.${2}.0.0";
981 0         0 $mask = pack('L3C4',0xffffffff,0xffffffff,0xffffffff,255,_obits($2,$3),0,0);
982             }
983             elsif ($ip =~ m/^(\d+)-(\d+)\.?$/ and $1 <= $2 && $2 < 256) {
984 4         6 $ip = "${1}.0.0.0";
985 4         7 $mask = pack('L3C4',0xffffffff,0xffffffff,0xffffffff,_obits($1,$2),0,0,0)
986             }
987             elsif ($ip =~ m/^(\d+)\.(\d+)\.$/) {
988 1         4 $ip = "${1}.${2}.0.0";
989 1         2 $mask = $ffff0000;
990             }
991             elsif ($ip =~ m/^(\d+)\.(\d+)\.(\d+)-(\d+)\.?$/ && $3 <= $4 && $4 < 256) {
992 1         13 $ip = "${1}.${2}.${3}.0";
993 1         3 $mask = pack('L3C4',0xffffffff,0xffffffff,0xffffffff,255,255,_obits($3,$4),0);
994             }
995             elsif ($ip =~ m/^(\d+)\.(\d+)\.(\d+)\.$/) {
996 1         5 $ip = "${1}.${2}.${3}.0";
997 1         1 $mask = $ffffff00;
998             }
999             elsif ($ip =~ m/^(\d+)\.(\d+)\.(\d+)\.(\d+)-(\d+)$/ && $4 <= $5 && $5 < 256) {
1000 0         0 $ip = "${1}.${2}.${3}.${4}";
1001 0         0 $mask = pack('L3C4',0xffffffff,0xffffffff,0xffffffff,255,255,255,_obits($4,$5));
1002             }
1003             elsif ($ip =~ m/^(\d+\.\d+\.\d+\.\d+)
1004             \s*-\s*(\d+\.\d+\.\d+\.\d+)$/x) {
1005             # if ($noctal) {
1006             # return undef unless ($ip = inet_aton(_no_octal($1)));
1007             # return undef unless ($tmp = inet_aton(_no_octal($2)));
1008             # } else {
1009 0 0       0 return undef unless ($ip = inet_aton($1));
1010 0 0       0 return undef unless ($tmp = inet_aton($2));
1011             # }
1012             # check for left side greater than right side
1013             # save numeric difference in $mask
1014 0 0       0 return undef if ($tmp = unpack('N',$tmp) - unpack('N',$ip)) < 0;
1015 0         0 $ip = ipv4to6($ip);
1016 0         0 $tmp = pack('L3N',0,0,0,$tmp);
1017 0         0 $mask = ~$tmp;
1018 0 0       0 return undef if notcontiguous($mask);
1019             # check for non-aligned left side
1020 0 0       0 return undef if hasbits($ip & $tmp);
1021 0         0 last;
1022             }
1023             # check for resolvable IPv4 hosts
1024             elsif (! $NoFQDN && $ip !~ /[^a-zA-Z0-9\._-]/ && ($tmp = gethostbyname(fillIPv4($ip))) && $tmp ne $_v4zero && $tmp ne $_zero ) {
1025 4         26 $ip = ipv4to6($tmp);
1026 4         11 last;
1027             }
1028             # check for resolvable IPv6 hosts
1029             elsif (! $NoFQDN && $ip !~ /[^a-zA-Z0-9\._-]/ && havegethostbyname2() && ($tmp = naip_gethostbyname($ip))) {
1030 0         0 $ip = $tmp;
1031 0         0 $isV6 = 1;
1032 0         0 last;
1033             }
1034             elsif ($Accept_Binary_IP && ! $hasmask) {
1035 0 0       0 if (length($ip) == 4) {
    0          
1036 0         0 $ip = ipv4to6($ip);
1037             } elsif (length($ip) == 16) {
1038 0         0 $isV6 = 1;
1039             } else {
1040 0         0 return undef;
1041             }
1042 0         0 last;
1043             } else {
1044 0         0 return undef;
1045             }
1046 7035 50       14204 return undef unless defined ($ip = inet_aton($ip));
1047 7035         16518 $ip = ipv4to6($ip);
1048 7035         7605 last;
1049             }
1050             ########## continuing
1051             else { # ipv6 address
1052 216         225 $isV6 = 1;
1053 216 100       489 $ip = $1 if $ip =~ /\[([^\]]+)\]/; # transform URI notation
1054 216 50       5459 if (defined ($tmp = ipv6_aton($ip))) {
1055 216         9264 $ip = $tmp;
1056 216         326 last;
1057             }
1058             last if grep($ip eq $_,(qw(default any loopback unspecified))) &&
1059 0 0 0     0 defined ($ip = $fip6{$ip});
1060 0         0 return undef;
1061             }
1062             } # end while (1)
1063 7433 100       18607 return undef if notcontiguous($mask); # invalid if not contiguous
1064              
1065 7431         20264 my $self = {
1066             addr => $ip,
1067             mask => $mask,
1068             isv6 => $isV6,
1069             };
1070 7431         48396 return bless $self, $class;
1071             }
1072              
1073             =item C<-Ebroadcast()>
1074              
1075             Returns a new object referring to the broadcast address of a given
1076             subnet. The broadcast address has all ones in all the bit positions
1077             where the netmask has zero bits. This is normally used to address all
1078             the hosts in a given subnet.
1079              
1080             =cut
1081              
1082             sub broadcast ($) {
1083 8867     8867 1 28459 my $ip = _new($_[0],$_[0]->{addr} | ~$_[0]->{mask},$_[0]->{mask});
1084 8867 100       19817 $ip->{addr} &= V4net unless $ip->{isv6};
1085 8867         17602 return $ip;
1086             }
1087              
1088             =item C<-Enetwork()>
1089              
1090             Returns a new object referring to the network address of a given
1091             subnet. A network address has all zero bits where the bits of the
1092             netmask are zero. Normally this is used to refer to a subnet.
1093              
1094             =cut
1095              
1096             sub network ($) {
1097 59403     59403 1 160175 return _new($_[0],$_[0]->{addr} & $_[0]->{mask},$_[0]->{mask});
1098             }
1099              
1100             =item C<-Eaddr()>
1101              
1102             Returns a scalar with the address part of the object as an IPv4 or IPv6 text
1103             string as appropriate. This is useful for printing or for passing the address
1104             part of the NetAddr::IP::Lite object to other components that expect an IP
1105             address. If the object is an ipV6 address or was created using ->new6($ip)
1106             it will be reported in ipV6 hex format otherwise it will be reported in dot
1107             quad format only if it resides in ipV4 address space.
1108              
1109             =cut
1110              
1111             sub addr ($) {
1112             return ($_[0]->{isv6})
1113             ? ipv6_n2x($_[0]->{addr})
1114 100646 100   100646 1 1991807 : inet_n2dx($_[0]->{addr});
1115             }
1116              
1117             =item C<-Emask()>
1118              
1119             Returns a scalar with the mask as an IPv4 or IPv6 text string as
1120             described above.
1121              
1122             =cut
1123              
1124             sub mask ($) {
1125 4 50   4 1 54 return ipv6_n2x($_[0]->{mask}) if $_[0]->{isv6};
1126             my $mask = isIPv4($_[0]->{addr})
1127             ? $_[0]->{mask} & V4net
1128 4 50       14 : $_[0]->{mask};
1129 4         83 return inet_n2dx($mask);
1130             }
1131              
1132             =item C<-Emasklen()>
1133              
1134             Returns a scalar the number of one bits in the mask.
1135              
1136             =cut
1137              
1138             sub masklen ($) {
1139 40545     40545 1 133029 my $len = (notcontiguous($_[0]->{mask}))[1];
1140 40545 100       64544 return 0 unless $len;
1141 40532 100       117887 return $len if $_[0]->{isv6};
1142             return isIPv4($_[0]->{addr})
1143 15547 50       29633 ? $len -96
1144             : $len;
1145             }
1146              
1147             =item C<-Ebits()>
1148              
1149             Returns the width of the address in bits. Normally 32 for v4 and 128 for v6.
1150              
1151             =cut
1152              
1153             sub bits {
1154 0 0   0 1 0 return $_[0]->{isv6} ? 128 : 32;
1155             }
1156              
1157             =item C<-Eversion()>
1158              
1159             Returns the version of the address or subnet. Currently this can be
1160             either 4 or 6.
1161              
1162             =cut
1163              
1164             sub version {
1165 0     0 1 0 my $self = shift;
1166 0 0       0 return $self->{isv6} ? 6 : 4;
1167             }
1168              
1169             =item C<-Ecidr()>
1170              
1171             Returns a scalar with the address and mask in CIDR notation. A
1172             NetAddr::IP::Lite object I to the result of this function.
1173             (see comments about ->new6() and ->addr() for output formats)
1174              
1175             =cut
1176              
1177             sub cidr ($) {
1178 22845     22845 1 30629 return $_[0]->addr . '/' . $_[0]->masklen;
1179             }
1180              
1181             =item C<-Eaton()>
1182              
1183             Returns the address part of the NetAddr::IP::Lite object in the same format
1184             as the C or C function respectively. If the object
1185             was created using ->new6($ip), the address returned will always be in ipV6
1186             format, even for addresses in ipV4 address space.
1187              
1188             =cut
1189              
1190             sub aton {
1191 0 0   0 1 0 return $_[0]->{addr} if $_[0]->{isv6};
1192             return isIPv4($_[0]->{addr})
1193             ? ipv6to4($_[0]->{addr})
1194 0 0       0 : $_[0]->{addr};
1195             }
1196              
1197             =item C<-Erange()>
1198              
1199             Returns a scalar with the base address and the broadcast address
1200             separated by a dash and spaces. This is called range notation.
1201              
1202             =cut
1203              
1204             sub range ($) {
1205 0     0 1 0 return $_[0]->network->addr . ' - ' . $_[0]->broadcast->addr;
1206             }
1207              
1208             =item C<-Enumeric()>
1209              
1210             When called in a scalar context, will return a numeric representation
1211             of the address part of the IP address. When called in an array
1212             context, it returns a list of two elements. The first element is as
1213             described, the second element is the numeric representation of the
1214             netmask.
1215              
1216             This method is essential for serializing the representation of a
1217             subnet.
1218              
1219             =cut
1220              
1221             sub numeric ($) {
1222 0 0   0 1 0 if (wantarray) {
1223 0 0 0     0 if (! $_[0]->{isv6} && isIPv4($_[0]->{addr})) {
1224             return ( sprintf("%u",unpack('N',ipv6to4($_[0]->{addr}))),
1225 0         0 sprintf("%u",unpack('N',ipv6to4($_[0]->{mask}))));
1226             }
1227             else {
1228             return ( bin2bcd($_[0]->{addr}),
1229 0         0 bin2bcd($_[0]->{mask}));
1230             }
1231             }
1232             return (! $_[0]->{isv6} && isIPv4($_[0]->{addr}))
1233             ? sprintf("%u",unpack('N',ipv6to4($_[0]->{addr})))
1234 0 0 0     0 : bin2bcd($_[0]->{addr});
1235             }
1236              
1237             =item C<-Ebigint()>
1238              
1239             When called in a scalar context, will return a Math::BigInt representation
1240             of the address part of the IP address. When called in an array
1241             contest, it returns a list of two elements. The first element is as
1242             described, the second element is the Math::BigInt representation of the
1243             netmask.
1244              
1245             =cut
1246              
1247             my $biloaded;
1248             my $bi2strng;
1249             my $no_mbi_emu = 1;
1250              
1251             # function to force into test development mode
1252             #
1253             sub _force_bi_emu {
1254 0     0   0 undef $biloaded;
1255 0         0 undef $bi2strng;
1256 0         0 $no_mbi_emu = 0;
1257 0         0 print STDERR "\n\n\tWARNING: test development mode, this
1258             \tmessage SHOULD NEVER BE SEEN IN PRODUCTION!
1259             set my \$no_mbi_emu = 1 in t/bigint.t to remove this warning\n\n";
1260             }
1261              
1262             # function to stringify various flavors of Math::BigInt objects
1263             # tests to see if the object is a hash or a signed scalar
1264              
1265             sub _bi_stfy {
1266 0     0   0 "$_[0]" =~ /(\d+)/; # stringify and remove '+' if present
1267 0         0 $1;
1268             }
1269              
1270             sub _fakebi2strg {
1271 0     0   0 ${$_[0]} =~ /(\d+)/;
  0         0  
1272 0         0 $1;
1273             }
1274              
1275             # fake new from bi string Math::BigInt 0.01
1276             #
1277             sub _bi_fake {
1278 0     0   0 bless \('+'. $_[1]), 'Math::BigInt';
1279             }
1280              
1281             # as of this writing there are three known flavors of Math::BigInt
1282             # v0.01 MBI::new returns a scalar ref
1283             # v1.?? - 1.69 CALC::_new takes a reference to a scalar, returns an array, MBI returns a hash ref
1284             # v1.70 and up CALC::_new takes a scalar, returns and array, MBI returns a hash ref
1285              
1286             sub _loadMBI { # load Math::BigInt on demand
1287 0 0   0   0 if (eval {$no_mbi_emu && require Math::BigInt}) { # any version should work, three known
  0 0       0  
1288 0         0 import Math::BigInt;
1289 0         0 $biloaded = \&Math::BigInt::new;
1290 0         0 $bi2strng = \&_bi_stfy;
1291             } else {
1292 0         0 $biloaded = \&_bi_fake;
1293 0         0 $bi2strng = \&_fakebi2strg;
1294             }
1295             }
1296              
1297             sub _retMBIstring {
1298 0 0   0   0 _loadMBI unless $biloaded; # load Math::BigInt on demand
1299 0         0 $bi2strng->(@_);
1300             }
1301              
1302             sub _biRef {
1303 0 0   0   0 _loadMBI unless $biloaded; # load Math::BigInt on demand
1304 0         0 $biloaded->('Math::BigInt',$_[0]);
1305             }
1306              
1307             sub bigint($) {
1308 0     0 1 0 my($addr,$mask);
1309 0 0       0 if (wantarray) {
1310 0 0 0     0 if (! $_[0]->{isv6} && isIPv4($_[0]->{addr})) {
1311             $addr = $_[0]->{addr}
1312 0 0       0 ? sprintf("%u",unpack('N',ipv6to4($_[0]->{addr})))
1313             : 0;
1314             $mask = $_[0]->{mask}
1315 0 0       0 ? sprintf("%u",unpack('N',ipv6to4($_[0]->{mask})))
1316             : 0;
1317             }
1318             else {
1319             $addr = $_[0]->{addr}
1320             ? bin2bcd($_[0]->{addr})
1321 0 0       0 : 0;
1322             $mask = $_[0]->{mask}
1323             ? bin2bcd($_[0]->{mask})
1324 0 0       0 : 0;
1325             }
1326 0         0 (_biRef($addr),_biRef($mask));
1327              
1328             } else { # not wantarray
1329              
1330 0 0 0     0 if (! $_[0]->{isv6} && isIPv4($_[0]->{addr})) {
1331             $addr = $_[0]->{addr}
1332 0 0       0 ? sprintf("%u",unpack('N',ipv6to4($_[0]->{addr})))
1333             : 0;
1334             } else {
1335             $addr = $_[0]->{addr}
1336             ? bin2bcd($_[0]->{addr})
1337 0 0       0 : 0;
1338             }
1339 0         0 _biRef($addr);
1340             }
1341             }
1342              
1343             =item C<$me-Econtains($other)>
1344              
1345             Returns true when C<$me> completely contains C<$other>. False is
1346             returned otherwise and C is returned if C<$me> and C<$other>
1347             are not both C objects.
1348              
1349             =cut
1350              
1351             sub contains ($$) {
1352 293316     293316 1 381449 return within(@_[1,0]);
1353             }
1354              
1355             =item C<$me-Ewithin($other)>
1356              
1357             The complement of C<-Econtains()>. Returns true when C<$me> is
1358             completely contained within C<$other>, undef if C<$me> and C<$other>
1359             are not both C objects.
1360              
1361             =cut
1362              
1363             sub within ($$) {
1364 293316 50   293316 1 675183 return 1 unless hasbits($_[1]->{mask}); # 0x0 contains everything
1365 293316         437219 my $netme = $_[0]->{addr} & $_[0]->{mask};
1366 293316         380765 my $brdme = $_[0]->{addr} | ~ $_[0]->{mask};
1367 293316         318321 my $neto = $_[1]->{addr} & $_[1]->{mask};
1368 293316         337046 my $brdo = $_[1]->{addr} | ~ $_[1]->{mask};
1369 293316 100 100     6384285 return (sub128($netme,$neto) && sub128($brdo,$brdme))
1370             ? 1 : 0;
1371             }
1372              
1373             =item C-Eis_rfc1918()>
1374              
1375             Returns true when C<$me> is an RFC 1918 address.
1376              
1377             10.0.0.0 - 10.255.255.255 (10/8 prefix)
1378             172.16.0.0 - 172.31.255.255 (172.16/12 prefix)
1379             192.168.0.0 - 192.168.255.255 (192.168/16 prefix)
1380              
1381             =cut
1382              
1383             my $ip_10 = NetAddr::IP::Lite->new('10.0.0.0/8');
1384             my $ip_10n = $ip_10->{addr}; # already the right value
1385             my $ip_10b = $ip_10n | ~ $ip_10->{mask};
1386              
1387             my $ip_172 = NetAddr::IP::Lite->new('172.16.0.0/12');
1388             my $ip_172n = $ip_172->{addr}; # already the right value
1389             my $ip_172b = $ip_172n | ~ $ip_172->{mask};
1390              
1391             my $ip_192 = NetAddr::IP::Lite->new('192.168.0.0/16');
1392             my $ip_192n = $ip_192->{addr}; # already the right value
1393             my $ip_192b = $ip_192n | ~ $ip_192->{mask};
1394              
1395             sub is_rfc1918 ($) {
1396 0     0 1 0 my $netme = $_[0]->{addr} & $_[0]->{mask};
1397 0         0 my $brdme = $_[0]->{addr} | ~ $_[0]->{mask};
1398 0 0 0     0 return 1 if (sub128($netme,$ip_10n) && sub128($ip_10b,$brdme));
1399 0 0 0     0 return 1 if (sub128($netme,$ip_192n) && sub128($ip_192b,$brdme));
1400 0 0 0     0 return (sub128($netme,$ip_172n) && sub128($ip_172b,$brdme))
1401             ? 1 : 0;
1402             }
1403              
1404             =item C<-Eis_local()>
1405              
1406             Returns true when C<$me> is a local network address.
1407              
1408             i.e. ipV4 127.0.0.0 - 127.255.255.255
1409             or ipV6 === ::1
1410              
1411             =cut
1412              
1413             my $_lclhost6 = NetAddr::IP::Lite->new('::1');
1414             my $_lclnet = NetAddr::IP::Lite->new('127/8');
1415              
1416             sub is_local ($) {
1417             return ($_[0]->{isv6})
1418 0 0   0 1 0 ? $_[0] == $_lclhost6
1419             : $_[0]->within($_lclnet);
1420             }
1421              
1422             =item C<-Efirst()>
1423              
1424             Returns a new object representing the first usable IP address within
1425             the subnet (ie, the first host address).
1426              
1427             =cut
1428              
1429             my $_cidr127 = pack('N4',0xffffffff,0xffffffff,0xffffffff,0xfffffffe);
1430              
1431             sub first ($) {
1432 16 50   16 1 60 if (hasbits($_[0]->{mask} ^ $_cidr127)) {
1433 16         28 return $_[0]->network + 1;
1434             } else {
1435 0         0 return $_[0]->network;
1436             }
1437             # return $_[0]->network + 1;
1438             }
1439              
1440             =item C<-Elast()>
1441              
1442             Returns a new object representing the last usable IP address within
1443             the subnet (ie, one less than the broadcast address).
1444              
1445             =cut
1446              
1447             sub last ($) {
1448 3 50   3 1 12 if (hasbits($_[0]->{mask} ^ $_cidr127)) {
1449 3         4 return $_[0]->broadcast - 1;
1450             } else {
1451 0         0 return $_[0]->broadcast;
1452             }
1453             # return $_[0]->broadcast - 1;
1454             }
1455              
1456             =item C<-Enth($index)>
1457              
1458             Returns a new object representing the I-th usable IP address within
1459             the subnet (ie, the I-th host address). If no address is available
1460             (for example, when the network is too small for C<$index> hosts),
1461             C is returned.
1462              
1463             Version 4.00 of NetAddr::IP and version 1.00 of NetAddr::IP::Lite implements
1464             C<-Enth($index)> and C<-Enum()> exactly as the documentation states.
1465             Previous versions behaved slightly differently and not in a consistent
1466             manner.
1467              
1468             To use the old behavior for C<-Enth($index)> and C<-Enum()>:
1469              
1470             use NetAddr::IP::Lite qw(:old_nth);
1471              
1472             old behavior:
1473             NetAddr::IP->new('10/32')->nth(0) == undef
1474             NetAddr::IP->new('10/32')->nth(1) == undef
1475             NetAddr::IP->new('10/31')->nth(0) == undef
1476             NetAddr::IP->new('10/31')->nth(1) == 10.0.0.1/31
1477             NetAddr::IP->new('10/30')->nth(0) == undef
1478             NetAddr::IP->new('10/30')->nth(1) == 10.0.0.1/30
1479             NetAddr::IP->new('10/30')->nth(2) == 10.0.0.2/30
1480             NetAddr::IP->new('10/30')->nth(3) == 10.0.0.3/30
1481              
1482             Note that in each case, the broadcast address is represented in the
1483             output set and that the 'zero'th index is alway undef except for
1484             a point-to-point /31 or /127 network where there are exactly two
1485             addresses in the network.
1486              
1487             new behavior:
1488             NetAddr::IP->new('10/32')->nth(0) == 10.0.0.0/32
1489             NetAddr::IP->new('10.1/32'->nth(0) == 10.0.0.1/32
1490             NetAddr::IP->new('10/31')->nth(0) == 10.0.0.0/32
1491             NetAddr::IP->new('10/31')->nth(1) == 10.0.0.1/32
1492             NetAddr::IP->new('10/30')->nth(0) == 10.0.0.1/30
1493             NetAddr::IP->new('10/30')->nth(1) == 10.0.0.2/30
1494             NetAddr::IP->new('10/30')->nth(2) == undef
1495              
1496             Note that a /32 net always has 1 usable address while a /31 has exactly
1497             two usable addresses for point-to-point addressing. The first
1498             index (0) returns the address immediately following the network address
1499             except for a /31 or /127 when it return the network address.
1500              
1501             =cut
1502              
1503             sub nth ($$) {
1504 0     0 1 0 my $self = shift;
1505 0         0 my $count = shift;
1506              
1507 0         0 my $slash31 = ! hasbits($self->{mask} ^ $_cidr127);
1508 0 0       0 if ($Old_nth) {
    0          
1509 0 0 0     0 return undef if $slash31 && $count != 1;
1510 0 0 0     0 return undef if ($count < 1 or $count > $self->num ());
1511             }
1512             elsif ($slash31) {
1513 0 0 0     0 return undef if ($count && $count != 1); # only index 0, 1 allowed for /31
1514             } else {
1515 0         0 ++$count;
1516 0 0 0     0 return undef if ($count < 1 or $count > $self->num ());
1517             }
1518 0         0 return $self->network + $count;
1519             }
1520              
1521             =item C<-Enum()>
1522              
1523             As of version 4.42 of NetAddr::IP and version 1.27 of NetAddr::IP::Lite
1524             a /31 and /127 with return a net B value of 2 instead of 0 (zero)
1525             for point-to-point networks.
1526              
1527             Version 4.00 of NetAddr::IP and version 1.00 of NetAddr::IP::Lite
1528             return the number of usable IP addresses within the subnet,
1529             not counting the broadcast or network address.
1530              
1531             Previous versions worked only for ipV4 addresses, returned a
1532             maximum span of 2**32 and returned the number of IP addresses
1533             not counting the broadcast address.
1534             (one greater than the new behavior)
1535              
1536             To use the old behavior for C<-Enth($index)> and C<-Enum()>:
1537              
1538             use NetAddr::IP::Lite qw(:old_nth);
1539              
1540             WARNING:
1541              
1542             NetAddr::IP will calculate and return a numeric string for network
1543             ranges as large as 2**128. These values are TEXT strings and perl
1544             can treat them as integers for numeric calculations.
1545              
1546             Perl on 32 bit platforms only handles integer numbers up to 2**32
1547             and on 64 bit platforms to 2**64.
1548              
1549             If you wish to manipulate numeric strings returned by NetAddr::IP
1550             that are larger than 2**32 or 2**64, respectively, you must load
1551             additional modules such as Math::BigInt, bignum or some similar
1552             package to do the integer math.
1553              
1554             =cut
1555              
1556             sub num ($) {
1557 4608 100   4608 1 7702 if ($Old_nth) {
1558 2304         5064 my @net = unpack('L3N',$_[0]->{mask} ^ Ones);
1559             # number of ip's less broadcast
1560 2304 50 33     11061 return 0xfffffffe if $net[0] || $net[1] || $net[2]; # 2**32 -1
      33        
1561 2304 50       67542 return $net[3] if $net[3];
1562             } else { # returns 1 for /32 /128, 2 for /31 /127 else n-2 up to 2**32
1563 2304         5492 (undef, my $net) = addconst($_[0]->{mask},1);
1564 2304 50       42569 return 1 unless hasbits($net); # ipV4/32 or ipV6/128
1565 0         0 $net = $net ^ Ones;
1566 0 0       0 return 2 unless hasbits($net); # ipV4/31 or ipV6/127
1567 0 0       0 $net &= $_v4net unless $_[0]->{isv6};
1568 0         0 return bin2bcd($net);
1569             }
1570             }
1571              
1572             # deprecated
1573             #sub num ($) {
1574             # my @net = unpack('L3N',$_[0]->{mask} ^ Ones);
1575             # if ($Old_nth) {
1576             ## number of ip's less broadcast
1577             # return 0xfffffffe if $net[0] || $net[1] || $net[2]; # 2**32 -1
1578             # return $net[3] if $net[3];
1579             # } else { # returns 1 for /32 /128, 0 for /31 /127 else n-2 up to 2**32
1580             ## number of usable IP's === number of ip's less broadcast & network addys
1581             # return 0xfffffffd if $net[0] || $net[1] || $net[2]; # 2**32 -2
1582             # return 1 unless $net[3];
1583             # $net[3]--;
1584             # }
1585             # return $net[3];
1586             #}
1587              
1588             =pod
1589              
1590             =back
1591              
1592             =cut
1593              
1594             sub import {
1595 32 50   32   66 if (grep { $_ eq ':aton' } @_) {
  192         380  
1596 0         0 $Accept_Binary_IP = 1;
1597 0         0 @_ = grep { $_ ne ':aton' } @_;
  0         0  
1598             }
1599 32 50       53 if (grep { $_ eq ':old_nth' } @_) {
  192         250  
1600 0         0 $Old_nth = 1;
1601 0         0 @_ = grep { $_ ne ':old_nth' } @_;
  0         0  
1602             }
1603 32 50       51 if (grep { $_ eq ':lower' } @_)
  192         252  
1604             {
1605 0         0 NetAddr::IP::Util::lower();
1606 0         0 @_ = grep { $_ ne ':lower' } @_;
  0         0  
1607             }
1608 32 50       46 if (grep { $_ eq ':upper' } @_)
  192         249  
1609             {
1610 0         0 NetAddr::IP::Util::upper();
1611 0         0 @_ = grep { $_ ne ':upper' } @_;
  0         0  
1612             }
1613 32 50       43 if (grep { $_ eq ':nofqdn' } @_)
  192         271  
1614             {
1615 0         0 $NoFQDN = 1;
1616 0         0 @_ = grep { $_ ne ':nofqdn' } @_;
  0         0  
1617             }
1618 32         5118 NetAddr::IP::Lite->export_to_level(1, @_);
1619             }
1620              
1621             =head1 EXPORT_OK
1622              
1623             Zeros
1624             Ones
1625             V4mask
1626             V4net
1627             :aton DEPRECATED
1628             :old_nth
1629             :upper
1630             :lower
1631             :nofqdn
1632              
1633             =head1 AUTHORS
1634              
1635             Luis E. Muñoz Eluismunoz@cpan.orgE,
1636             Michael Robinton Emichael@bizsystems.comE
1637              
1638             =head1 WARRANTY
1639              
1640             This software comes with the same warranty as perl itself (ie, none),
1641             so by using it you accept any and all the liability.
1642              
1643             =head1 COPYRIGHT
1644              
1645             This software is (c) Luis E. Muñoz, 1999 - 2005
1646             and (c) Michael Robinton, 2006 - 2014.
1647              
1648             All rights reserved.
1649              
1650             This program is free software; you can redistribute it and/or modify
1651             it under the terms of either:
1652              
1653             a) the GNU General Public License as published by the Free
1654             Software Foundation; either version 2, or (at your option) any
1655             later version, or
1656              
1657             b) the "Artistic License" which comes with this distribution.
1658              
1659             This program is distributed in the hope that it will be useful,
1660             but WITHOUT ANY WARRANTY; without even the implied warranty of
1661             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
1662             the GNU General Public License or the Artistic License for more details.
1663              
1664             You should have received a copy of the Artistic License with this
1665             distribution, in the file named "Artistic". If not, I'll be glad to provide
1666             one.
1667              
1668             You should also have received a copy of the GNU General Public License
1669             along with this program in the file named "Copying". If not, write to the
1670              
1671             Free Software Foundation, Inc.,
1672             51 Franklin Street, Fifth Floor
1673             Boston, MA 02110-1301 USA
1674              
1675             or visit their web page on the internet at:
1676              
1677             http://www.gnu.org/copyleft/gpl.html.
1678              
1679             =head1 SEE ALSO
1680              
1681             NetAddr::IP(3), NetAddr::IP::Util(3), NetAddr::IP::InetBase(3)
1682              
1683             =cut
1684              
1685             1;