File Coverage

blib/lib/NetAddr/IP/Lite.pm
Criterion Covered Total %
statement 190 397 47.8
branch 128 310 41.2
condition 47 218 21.5
subroutine 37 66 56.0
pod 27 36 75.0
total 429 1027 41.7


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2              
3             package NetAddr::IP::Lite;
4              
5 31     31   180 use Carp;
  31         59  
  31         2227  
6 31     31   161 use strict;
  31         52  
  31         1172  
7             #use diagnostics;
8             #use warnings;
9 31         255 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 31     31   35006 );
  31         376  
18 31         178 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 31     31   25455 );
  31         106  
32              
33 31     31   181 use vars qw(@ISA @EXPORT_OK $VERSION $Accept_Binary_IP $Old_nth $NoFQDN $AUTOLOAD *Zero);
  31         127  
  31         9329  
34              
35             $VERSION = do { my @r = (q$Revision: 1.54 $ =~ /\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     0   0 sub DESTROY {};
172              
173             sub AUTOLOAD {
174 31     31   182 no strict;
  31         59  
  31         38053  
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 281     281 0 1452 return $_zero;
210             }
211             sub Ones() {
212 8866     8866 0 38955 return $_ones;
213             }
214             sub V4mask() {
215 3     3 0 56 return $_v4mask;
216             }
217             sub V4net() {
218 336     336 0 816 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 22259     22259   92501 '""' => sub { $_[0]->cidr(); },
239              
240             'eq' => sub {
241 533 50   533   8693 my $a = (UNIVERSAL::isa($_[0],__PACKAGE__)) ? $_[0]->cidr : $_[0];
242 533 100       3024 my $b = (UNIVERSAL::isa($_[1],__PACKAGE__)) ? $_[1]->cidr : $_[1];
243 533         1877 $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   51 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   125 return &comp_addr_mask > 0 ? 1 : 0;
264             },
265              
266             '<' => sub {
267 8464 100   8464   18999 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 31         1036 '<=>' => \&comp_addr_mask,
279              
280 31     31   39671 'cmp' => \&comp_addr_mask;
  31         21612  
281              
282             sub comp_addr_mask {
283 68742     68742 0 282421 my($c,$rv) = sub128($_[0]->{addr},$_[1]->{addr});
284 68742 100       232447 return -1 unless $c;
285 3621 100       13637 return 1 if hasbits($rv);
286 199         965 ($c,$rv) = sub128($_[0]->{mask},$_[1]->{mask});
287 199 100       6911 return -1 unless $c;
288 167 100       930 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 153805 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 1414 my $ip = shift;
386 24         28 my $const = shift;
387              
388 24 50 66     172 return $ip unless $const &&
      66        
389             $const < 2147483648 &&
390             $const > -2147483649;
391              
392 23         40 my $a = $ip->{addr};
393 23         40 my $m = $ip->{mask};
394              
395 23         46 my $lo = $a & ~$m;
396 23         36 my $hi = $a & $m;
397              
398 23         105 my $new = ((addconst($lo,$const))[1] & ~$m) | $hi;
399              
400 23         50 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         5 my $arg = shift;
421 3 50       9 unless (ref $arg) {
422 3         9 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 3876482 my $ip = shift;
446              
447 8333         25239 my $a = $ip->{addr};
448 8333         19208 my $m = $ip->{mask};
449              
450 8333         19815 my $lo = $a & ~ $m;
451 8333         11588 my $hi = $a & $m;
452              
453 8333         43608 $ip->{addr} = ((addconst($lo,1))[1] & ~ $m) | $hi;
454 8333         63425 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   235252 my $proto = shift;
494 150298   50     352138 my $class = ref($proto) || die "reference required";
495 150298         266337 $proto = $proto->{isv6};
496 150298         514744 my $self = {
497             addr => $_[0],
498             mask => $_[1],
499             isv6 => $proto,
500             };
501 150298         4219670 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   13 my($lo,$hi) = @_;
689              
690 5 50       14 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 7367     7367 1 131697 unshift @_, 0;
701 7367         18603 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     0   0 $_[0] =~ m/^(\d+)\.(\d+)\.(\d+)\.(\d+)$/;
750 0         0 return sprintf("%d.%d.%d.%d",$1,$2,$3,$4);
751             }
752              
753             sub _xnew($$;$$) {
754 7367     7367   8304 my $noctal = 0;
755 7367         10105 my $isV6 = shift;
756 7367 50       16418 if ($isV6 < 0) { # flag for no octal?
757 0         0 $isV6 = 0;
758 0         0 $noctal = 1;
759             }
760 7367         8797 my $proto = shift;
761 7367   50     31037 my $class = ref $proto || $proto || __PACKAGE__;
762 7367         9593 my $ip = shift;
763              
764             # fix for bug #75976
765 7367 50 33     34463 return undef if defined $ip && $ip eq '';
766              
767 7367 50       13718 $ip = 'default' unless defined $ip;
768 7367 50 33     22462 $ip = _retMBIstring($ip) # treat as big bcd string
769             if ref $ip && ref $ip eq 'Math::BigInt'; # can /CIDR notation
770 7367         8035 my $hasmask = 1;
771 7367         6892 my($mask,$tmp);
772              
773             # IP to lower case AFTER ref test for Math::BigInt. 'lc' strips blessing
774              
775 7367         12313 $ip = lc $ip;
776              
777 7367         7632 while (1) {
778             # process IP's with no CIDR or that have the CIDR as part of the IP argument string
779 7367 100       14424 unless (@_) {
    50          
780             # if ($ip =~ m!^(.+)/(.+)$!) {
781 6829 50 66     50540 if ($ip !~ /\D/) { # binary number notation
    100          
    100          
782 0         0 $ip = bcd2bin($ip);
783 0         0 $mask = Ones;
784 0         0 last;
785             }
786             elsif ($ip =~ m!^([a-z0-9.:-]+)(?:/|\s+)([a-z0-9.:-]+)$! ||
787             $ip =~ m!^[\[]{1}([a-z0-9.:-]+)(?:/|\s+)([a-z0-9.:-]+)[\]]{1}$!) {
788 5839         10394 $ip = $1;
789 5839         11210 $mask = $2;
790             } elsif (grep($ip eq $_,(qw(default any broadcast loopback unspecified)))) {
791 9 50       25 $isV6 = 1 if $ip eq 'unspecified';
792 9 50       22 if ($isV6) {
793 0         0 $mask = $fip6m{$ip};
794 0 0       0 return undef unless defined ($ip = $fip6{$ip});
795             } else {
796 9         20 $mask = $fip4m{$ip};
797 9 50       31 return undef unless defined ($ip = $fip4{$ip});
798             }
799 9         14 last;
800             }
801             }
802             # process "ipv6" token and default IP's
803             elsif (defined $_[0]) {
804 538 50 33     2197 if ($_[0] =~ /ipv6/i || $isV6) {
805 0 0       0 if (grep($ip eq $_,(qw(default any loopback unspecified)))) {
806 0         0 $mask = $fip6m{$ip};
807 0         0 $ip = $fip6{$ip};
808 0         0 last;
809             } else {
810 0 0       0 return undef unless $isV6;
811             # add for ipv6 notation "12345, 1"
812             }
813             # $mask = lc $_[0];
814             # } else {
815             # $mask = lc $_[0];
816             }
817             # extract mask
818 538         950 $mask = $_[0];
819             }
820             ###
821             ### process mask
822 7358 100       13749 unless (defined $mask) {
823 981         1192 $hasmask = 0;
824 981         1303 $mask = 'host';
825             }
826              
827             # two kinds of IP's can turn on the isV6 flag
828             # 1) big digits that are over the IPv4 boundry
829             # 2) IPv6 IP syntax
830             #
831             # check these conditions and set isV6 as appropriate
832             #
833 7358         7152 my $try;
834 7358 100 0     69454 $isV6 = 1 if # check big bcd and IPv6 rfc1884
      33        
      0        
      0        
      100        
      33        
835             ( $ip !~ /\D/ && # ip is all decimal
836             (length($ip) > 3 || $ip > 255) && # exclude a single digit in the range of zero to 255, could be funny IPv4
837             ($try = bcd2bin($ip)) && ! isIPv4($try)) || # precedence so $try is not corrupted
838             (index($ip,':') >= 0 && ($try = ipv6_aton($ip))); # fails if not an rfc1884 address
839              
840             # if either of the above conditions is true, $try contains the NetAddr 128 bit address
841              
842             # checkfor Math::BigInt mask
843 7358 50 33     52021 $mask = _retMBIstring($mask) # treat as big bcd string
844             if ref $mask && ref $mask eq 'Math::BigInt';
845              
846             # MASK to lower case AFTER ref test for Math::BigInt, 'lc' strips blessing
847              
848 7358         10308 $mask = lc $mask;
849              
850 7358 100       22388 if ($mask !~ /\D/) { # bcd or CIDR notation
    100          
    100          
851 6364   33     24558 my $isCIDR = length($mask) < 4 && $mask < 129;
852 6364 100 33     29943 if ($isV6) {
    50          
853 169 50       270 if ($isCIDR) {
854 169         180 my($dq1,$dq2,$dq3,$dq4);
855 169 50 33     822 if ($ip =~ /^(\d+)(?:|\.(\d+)(?:|\.(\d+)(?:|\.(\d+))))$/ &&
  0 100 0     0  
      0        
      0        
      0        
      0        
      0        
      0        
      0        
856             do {$dq1 = $1;
857 0   0     0 $dq2 = $2 || 0;
858 0   0     0 $dq3 = $3 || 0;
859 0   0     0 $dq4 = $4 || 0;
860 0         0 1;
861             } &&
862             $dq1 >= 0 && $dq1 < 256 &&
863             $dq2 >= 0 && $dq2 < 256 &&
864             $dq3 >= 0 && $dq3 < 256 &&
865             $dq4 >= 0 && $dq4 < 256
866             ) { # corner condition of IPv4 with isV6
867 0         0 $ip = join('.',$dq1,$dq2,$dq3,$dq4);
868 0         0 $try = ipv4to6(inet_aton($ip));
869 0 0       0 if ($mask < 32) {
    0          
870 0         0 $mask = shiftleft(Ones,32 -$mask);
871             }
872             elsif ($mask == 32) {
873 0         0 $mask = Ones;
874             } else {
875 0         0 return undef; # undoubtably an error
876             }
877             }
878             elsif ($mask < 128) {
879 165         285 $mask = shiftleft(Ones,128 -$mask); # small cidr
880             } else {
881 4         10 $mask = Ones();
882             }
883             } else {
884 0         0 $mask = bcd2bin($mask);
885             }
886             }
887             elsif ($isCIDR && $mask < 33) { # is V4
888 6195 100       11365 if ($mask < 32) {
    50          
889 6165         10516 $mask = shiftleft(Ones,32 -$mask);
890             }
891             elsif ( $mask == 32) {
892 30         93 $mask = Ones;
893             } else {
894 0         0 $mask = bcd2bin($mask);
895 0         0 $mask |= $_v4mask; # v4 always
896             }
897             } else { # also V4
898 0         0 $mask = bcd2bin($mask);
899 0         0 $mask |= $_v4mask;
900             }
901 6364 100       15191 if ($try) { # is a big number
902 169         203 $ip = $try;
903 169         302 last;
904             }
905             } elsif ($mask =~ m/^\d+\.\d+\.\d+\.\d+$/) { # ipv4 form of mask
906 9 50       25 $mask = _no_octal($mask) if $noctal; # filter for octal
907 9 50       39 return undef unless defined ($mask = inet_aton($mask));
908 9         45 $mask = mask4to6($mask);
909             } elsif (grep($mask eq $_,qw(default any broadcast loopback unspecified host))) {
910 981 100 66     4000 if (index($ip,':') < 0 && ! $isV6) {
911 799 50       2063 return undef unless defined ($mask = $fip4m{$mask});
912             } else {
913 182 50       1187 return undef unless defined ($mask = $fip6m{$mask});
914             }
915             } else {
916 4 100       123 return undef unless defined ($mask = ipv6_aton($mask)); # try ipv6 form of mask
917             }
918              
919             # process remaining IP's
920              
921 7187 100       13964 if (index($ip,':') < 0) { # ipv4 address
922 7003 100 33     32638 if ($ip =~ m/^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) {
    50 33        
    100 0        
    100 33        
    50 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        
923             ; # the common case
924             }
925             elsif (grep($ip eq $_,(qw(default any broadcast loopback)))) {
926 0 0       0 return undef unless defined ($ip = $fip4{$ip});
927 0         0 last;
928             }
929             elsif ($ip =~ m/^(\d+)\.(\d+)$/) {
930 4 50       22 $ip = ($hasmask)
931             ? "${1}.${2}.0.0"
932             : "${1}.0.0.${2}";
933             }
934             elsif ($ip =~ m/^(\d+)\.(\d+)\.(\d+)$/) {
935 2 50       11 $ip = ($hasmask)
936             ? "${1}.${2}.${3}.0"
937             : "${1}.${2}.0.${3}";
938             }
939             elsif ($ip =~ /^(\d+)$/ && $hasmask && $1 >= 0 and $1 < 256) { # pure numeric
940 0         0 $ip = sprintf("%d.0.0.0",$1);
941             }
942             # elsif ($ip =~ /^\d+$/ && !$hasmask) { # a big integer
943             elsif ($ip =~ /^\d+$/ ) { # a big integer
944 0         0 $ip = bcd2bin($ip);
945 0         0 last;
946             }
947             # these next three might be broken??? but they have been in the code a long time and no one has complained
948             elsif ($ip =~ /^0[xb]\d+$/ && $hasmask &&
949             (($tmp = eval "$ip") || 1) &&
950             $tmp >= 0 && $tmp < 256) {
951 0         0 $ip = sprintf("%d.0.0.0",$tmp);
952             }
953             elsif ($ip =~ /^-?\d+$/) {
954 0 0       0 $ip += 2 ** 32 if $ip < 0;
955 0         0 $ip = pack('L3N',0,0,0,$ip);
956 0         0 last;
957             }
958             elsif ($ip =~ /^-?0[xb]\d+$/) {
959 0         0 $ip = eval "$ip";
960 0         0 $ip = pack('L3N',0,0,0,$ip);
961 0         0 last;
962             }
963              
964             # notations below include an implicit mask specification
965              
966             elsif ($ip =~ m/^(\d+)\.$/) {
967 1         3 $ip = "${1}.0.0.0";
968 1         3 $mask = $ff000000;
969             }
970             elsif ($ip =~ m/^(\d+)\.(\d+)-(\d+)\.?$/ && $2 <= $3 && $3 < 256) {
971 0         0 $ip = "${1}.${2}.0.0";
972 0         0 $mask = pack('L3C4',0xffffffff,0xffffffff,0xffffffff,255,_obits($2,$3),0,0);
973             }
974             elsif ($ip =~ m/^(\d+)-(\d+)\.?$/ and $1 <= $2 && $2 < 256) {
975 4         11 $ip = "${1}.0.0.0";
976 4         12 $mask = pack('L3C4',0xffffffff,0xffffffff,0xffffffff,_obits($1,$2),0,0,0)
977             }
978             elsif ($ip =~ m/^(\d+)\.(\d+)\.$/) {
979 1         7 $ip = "${1}.${2}.0.0";
980 1         3 $mask = $ffff0000;
981             }
982             elsif ($ip =~ m/^(\d+)\.(\d+)\.(\d+)-(\d+)\.?$/ && $3 <= $4 && $4 < 256) {
983 1         6 $ip = "${1}.${2}.${3}.0";
984 1         3 $mask = pack('L3C4',0xffffffff,0xffffffff,0xffffffff,255,255,_obits($3,$4),0);
985             }
986             elsif ($ip =~ m/^(\d+)\.(\d+)\.(\d+)\.$/) {
987 1         5 $ip = "${1}.${2}.${3}.0";
988 1         2 $mask = $ffffff00;
989             }
990             elsif ($ip =~ m/^(\d+)\.(\d+)\.(\d+)\.(\d+)-(\d+)$/ && $4 <= $5 && $5 < 256) {
991 0         0 $ip = "${1}.${2}.${3}.${4}";
992 0         0 $mask = pack('L3C4',0xffffffff,0xffffffff,0xffffffff,255,255,255,_obits($4,$5));
993             }
994             elsif ($ip =~ m/^(\d+\.\d+\.\d+\.\d+)
995             \s*-\s*(\d+\.\d+\.\d+\.\d+)$/x) {
996 0 0       0 if ($noctal) {
997 0 0       0 return undef unless ($ip = inet_aton(_no_octal($1)));
998 0 0       0 return undef unless ($tmp = inet_aton(_no_octal($2)));
999             } else {
1000 0 0       0 return undef unless ($ip = inet_aton($1));
1001 0 0       0 return undef unless ($tmp = inet_aton($2));
1002             }
1003             # check for left side greater than right side
1004             # save numeric difference in $mask
1005 0 0       0 return undef if ($tmp = unpack('N',$tmp) - unpack('N',$ip)) < 0;
1006 0         0 $ip = ipv4to6($ip);
1007 0         0 $tmp = pack('L3N',0,0,0,$tmp);
1008 0         0 $mask = ~$tmp;
1009 0 0       0 return undef if notcontiguous($mask);
1010             # check for non-aligned left side
1011 0 0       0 return undef if hasbits($ip & $tmp);
1012 0         0 last;
1013             }
1014             # check for resolvable IPv4 hosts
1015             elsif (! $NoFQDN && $ip !~ /[^a-zA-Z0-9\._-]/ && ($tmp = gethostbyname(fillIPv4($ip))) && $tmp ne $_v4zero && $tmp ne $_zero ) {
1016 3         19 $ip = ipv4to6($tmp);
1017 3         11 last;
1018             }
1019             # check for resolvable IPv6 hosts
1020             elsif (! $NoFQDN && $ip !~ /[^a-zA-Z0-9\._-]/ && havegethostbyname2() && ($tmp = naip_gethostbyname($ip))) {
1021 0         0 $ip = $tmp;
1022 0         0 $isV6 = 1;
1023 0         0 last;
1024             }
1025             elsif ($Accept_Binary_IP && ! $hasmask) {
1026 0 0       0 if (length($ip) == 4) {
    0          
1027 0         0 $ip = ipv4to6($ip);
1028             } elsif (length($ip) == 16) {
1029 0         0 $isV6 = 1;
1030             } else {
1031 0         0 return undef;
1032             }
1033 0         0 last;
1034             } else {
1035 0         0 return undef;
1036             }
1037 7000 50       18285 return undef unless defined ($ip = inet_aton($ip));
1038 7000         19230 $ip = ipv4to6($ip);
1039 7000         10191 last;
1040             }
1041             ########## continuing
1042             else { # ipv6 address
1043 184         311 $isV6 = 1;
1044 184 100       879 $ip = $1 if $ip =~ /\[([^\]]+)\]/; # transform URI notation
1045 184 50       7055 if (defined ($tmp = ipv6_aton($ip))) {
1046 184         10276 $ip = $tmp;
1047 184         385 last;
1048             }
1049 0 0 0     0 last if grep($ip eq $_,(qw(default any loopback unspecified))) &&
1050             defined ($ip = $fip6{$ip});
1051 0         0 return undef;
1052             }
1053             } # end while (1)
1054 7365 100       22122 return undef if notcontiguous($mask); # invalid if not contiguous
1055              
1056 7363         27581 my $self = {
1057             addr => $ip,
1058             mask => $mask,
1059             isv6 => $isV6,
1060             };
1061 7363         63283 return bless $self, $class;
1062             }
1063              
1064             =item C<-Ebroadcast()>
1065              
1066             Returns a new object referring to the broadcast address of a given
1067             subnet. The broadcast address has all ones in all the bit positions
1068             where the netmask has zero bits. This is normally used to address all
1069             the hosts in a given subnet.
1070              
1071             =cut
1072              
1073             sub broadcast ($) {
1074 8867     8867 1 44795 my $ip = _new($_[0],$_[0]->{addr} | ~$_[0]->{mask},$_[0]->{mask});
1075 8867 100       44496 $ip->{addr} &= V4net unless $ip->{isv6};
1076 8867         29060 return $ip;
1077             }
1078              
1079             =item C<-Enetwork()>
1080              
1081             Returns a new object referring to the network address of a given
1082             subnet. A network address has all zero bits where the bits of the
1083             netmask are zero. Normally this is used to refer to a subnet.
1084              
1085             =cut
1086              
1087             sub network ($) {
1088 59403     59403 1 324361 return _new($_[0],$_[0]->{addr} & $_[0]->{mask},$_[0]->{mask});
1089             }
1090              
1091             =item C<-Eaddr()>
1092              
1093             Returns a scalar with the address part of the object as an IPv4 or IPv6 text
1094             string as appropriate. This is useful for printing or for passing the address
1095             part of the NetAddr::IP::Lite object to other components that expect an IP
1096             address. If the object is an ipV6 address or was created using ->new6($ip)
1097             it will be reported in ipV6 hex format otherwise it will be reported in dot
1098             quad format only if it resides in ipV4 address space.
1099              
1100             =cut
1101              
1102             sub addr ($) {
1103 100645 100   100645 1 3205802 return ($_[0]->{isv6})
1104             ? ipv6_n2x($_[0]->{addr})
1105             : inet_n2dx($_[0]->{addr});
1106             }
1107              
1108             =item C<-Emask()>
1109              
1110             Returns a scalar with the mask as an IPv4 or IPv6 text string as
1111             described above.
1112              
1113             =cut
1114              
1115             sub mask ($) {
1116 4 50   4 1 79 return ipv6_n2x($_[0]->{mask}) if $_[0]->{isv6};
1117 4 50       21 my $mask = isIPv4($_[0]->{addr})
1118             ? $_[0]->{mask} & V4net
1119             : $_[0]->{mask};
1120 4         155 return inet_n2dx($mask);
1121             }
1122              
1123             =item C<-Emasklen()>
1124              
1125             Returns a scalar the number of one bits in the mask.
1126              
1127             =cut
1128              
1129             sub masklen ($) {
1130 40544     40544 1 196088 my $len = (notcontiguous($_[0]->{mask}))[1];
1131 40544 100       90228 return 0 unless $len;
1132 40531 100       170967 return $len if $_[0]->{isv6};
1133 15546 50       41079 return isIPv4($_[0]->{addr})
1134             ? $len -96
1135             : $len;
1136             }
1137              
1138             =item C<-Ebits()>
1139              
1140             Returns the width of the address in bits. Normally 32 for v4 and 128 for v6.
1141              
1142             =cut
1143              
1144             sub bits {
1145 0 0   0 1 0 return $_[0]->{isv6} ? 128 : 32;
1146             }
1147              
1148             =item C<-Eversion()>
1149              
1150             Returns the version of the address or subnet. Currently this can be
1151             either 4 or 6.
1152              
1153             =cut
1154              
1155             sub version {
1156 0     0 1 0 my $self = shift;
1157 0 0       0 return $self->{isv6} ? 6 : 4;
1158             }
1159              
1160             =item C<-Ecidr()>
1161              
1162             Returns a scalar with the address and mask in CIDR notation. A
1163             NetAddr::IP::Lite object I to the result of this function.
1164             (see comments about ->new6() and ->addr() for output formats)
1165              
1166             =cut
1167              
1168             sub cidr ($) {
1169 22844     22844 1 76395 return $_[0]->addr . '/' . $_[0]->masklen;
1170             }
1171              
1172             =item C<-Eaton()>
1173              
1174             Returns the address part of the NetAddr::IP::Lite object in the same format
1175             as the C or C function respectively. If the object
1176             was created using ->new6($ip), the address returned will always be in ipV6
1177             format, even for addresses in ipV4 address space.
1178              
1179             =cut
1180              
1181             sub aton {
1182 0 0   0 1 0 return $_[0]->{addr} if $_[0]->{isv6};
1183 0 0       0 return isIPv4($_[0]->{addr})
1184             ? ipv6to4($_[0]->{addr})
1185             : $_[0]->{addr};
1186             }
1187              
1188             =item C<-Erange()>
1189              
1190             Returns a scalar with the base address and the broadcast address
1191             separated by a dash and spaces. This is called range notation.
1192              
1193             =cut
1194              
1195             sub range ($) {
1196 0     0 1 0 return $_[0]->network->addr . ' - ' . $_[0]->broadcast->addr;
1197             }
1198              
1199             =item C<-Enumeric()>
1200              
1201             When called in a scalar context, will return a numeric representation
1202             of the address part of the IP address. When called in an array
1203             context, it returns a list of two elements. The first element is as
1204             described, the second element is the numeric representation of the
1205             netmask.
1206              
1207             This method is essential for serializing the representation of a
1208             subnet.
1209              
1210             =cut
1211              
1212             sub numeric ($) {
1213 0 0   0 1 0 if (wantarray) {
1214 0 0 0     0 if (! $_[0]->{isv6} && isIPv4($_[0]->{addr})) {
1215 0         0 return ( sprintf("%u",unpack('N',ipv6to4($_[0]->{addr}))),
1216             sprintf("%u",unpack('N',ipv6to4($_[0]->{mask}))));
1217             }
1218             else {
1219 0         0 return ( bin2bcd($_[0]->{addr}),
1220             bin2bcd($_[0]->{mask}));
1221             }
1222             }
1223 0 0 0     0 return (! $_[0]->{isv6} && isIPv4($_[0]->{addr}))
1224             ? sprintf("%u",unpack('N',ipv6to4($_[0]->{addr})))
1225             : bin2bcd($_[0]->{addr});
1226             }
1227              
1228             =item C<-Ebigint()>
1229              
1230             When called in a scalar context, will return a Math::BigInt representation
1231             of the address part of the IP address. When called in an array
1232             contest, it returns a list of two elements. The first element is as
1233             described, the second element is the Math::BigInt representation of the
1234             netmask.
1235              
1236             =cut
1237              
1238             my $biloaded;
1239             my $bi2strng;
1240             my $no_mbi_emu = 1;
1241              
1242             # function to force into test development mode
1243             #
1244             sub _force_bi_emu {
1245 0     0   0 undef $biloaded;
1246 0         0 undef $bi2strng;
1247 0         0 $no_mbi_emu = 0;
1248 0         0 print STDERR "\n\n\tWARNING: test development mode, this
1249             \tmessage SHOULD NEVER BE SEEN IN PRODUCTION!
1250             set my \$no_mbi_emu = 1 in t/bigint.t to remove this warning\n\n";
1251             }
1252              
1253             # function to stringify various flavors of Math::BigInt objects
1254             # tests to see if the object is a hash or a signed scalar
1255              
1256             sub _bi_stfy {
1257 0     0   0 "$_[0]" =~ /(\d+)/; # stringify and remove '+' if present
1258 0         0 $1;
1259             }
1260              
1261             sub _fakebi2strg {
1262 0     0   0 ${$_[0]} =~ /(\d+)/;
  0         0  
1263 0         0 $1;
1264             }
1265              
1266             # fake new from bi string Math::BigInt 0.01
1267             #
1268             sub _bi_fake {
1269 0     0   0 bless \('+'. $_[1]), 'Math::BigInt';
1270             }
1271              
1272             # as of this writing there are three known flavors of Math::BigInt
1273             # v0.01 MBI::new returns a scalar ref
1274             # v1.?? - 1.69 CALC::_new takes a reference to a scalar, returns an array, MBI returns a hash ref
1275             # v1.70 and up CALC::_new takes a scalar, returns and array, MBI returns a hash ref
1276              
1277             sub _loadMBI { # load Math::BigInt on demand
1278 0 0   0   0 if (eval {$no_mbi_emu && require Math::BigInt}) { # any version should work, three known
  0 0       0  
1279 0         0 import Math::BigInt;
1280 0         0 $biloaded = \&Math::BigInt::new;
1281 0         0 $bi2strng = \&_bi_stfy;
1282             } else {
1283 0         0 $biloaded = \&_bi_fake;
1284 0         0 $bi2strng = \&_fakebi2strg;
1285             }
1286             }
1287              
1288             sub _retMBIstring {
1289 0 0   0   0 _loadMBI unless $biloaded; # load Math::BigInt on demand
1290 0         0 $bi2strng->(@_);
1291             }
1292              
1293             sub _biRef {
1294 0 0   0   0 _loadMBI unless $biloaded; # load Math::BigInt on demand
1295 0         0 $biloaded->('Math::BigInt',$_[0]);
1296             }
1297              
1298             sub bigint($) {
1299 0     0 1 0 my($addr,$mask);
1300 0 0       0 if (wantarray) {
1301 0 0 0     0 if (! $_[0]->{isv6} && isIPv4($_[0]->{addr})) {
1302 0 0       0 $addr = $_[0]->{addr}
1303             ? sprintf("%u",unpack('N',ipv6to4($_[0]->{addr})))
1304             : 0;
1305 0 0       0 $mask = $_[0]->{mask}
1306             ? sprintf("%u",unpack('N',ipv6to4($_[0]->{mask})))
1307             : 0;
1308             }
1309             else {
1310 0 0       0 $addr = $_[0]->{addr}
1311             ? bin2bcd($_[0]->{addr})
1312             : 0;
1313 0 0       0 $mask = $_[0]->{mask}
1314             ? bin2bcd($_[0]->{mask})
1315             : 0;
1316             }
1317 0         0 (_biRef($addr),_biRef($mask));
1318              
1319             } else { # not wantarray
1320              
1321 0 0 0     0 if (! $_[0]->{isv6} && isIPv4($_[0]->{addr})) {
1322 0 0       0 $addr = $_[0]->{addr}
1323             ? sprintf("%u",unpack('N',ipv6to4($_[0]->{addr})))
1324             : 0;
1325             } else {
1326 0 0       0 $addr = $_[0]->{addr}
1327             ? bin2bcd($_[0]->{addr})
1328             : 0;
1329             }
1330 0         0 _biRef($addr);
1331             }
1332             }
1333              
1334             =item C<$me-Econtains($other)>
1335              
1336             Returns true when C<$me> completely contains C<$other>. False is
1337             returned otherwise and C is returned if C<$me> and C<$other>
1338             are not both C objects.
1339              
1340             =cut
1341              
1342             sub contains ($$) {
1343 293787     293787 1 597010 return within(@_[1,0]);
1344             }
1345              
1346             =item C<$me-Ewithin($other)>
1347              
1348             The complement of C<-Econtains()>. Returns true when C<$me> is
1349             completely contained within C<$other>, undef if C<$me> and C<$other>
1350             are not both C objects.
1351              
1352             =cut
1353              
1354             sub within ($$) {
1355 293787 50   293787 1 1023531 return 1 unless hasbits($_[1]->{mask}); # 0x0 contains everything
1356 293787         841097 my $netme = $_[0]->{addr} & $_[0]->{mask};
1357 293787         639250 my $brdme = $_[0]->{addr} | ~ $_[0]->{mask};
1358 293787         572421 my $neto = $_[1]->{addr} & $_[1]->{mask};
1359 293787         577389 my $brdo = $_[1]->{addr} | ~ $_[1]->{mask};
1360 293787 100 100     10210793 return (sub128($netme,$neto) && sub128($brdo,$brdme))
1361             ? 1 : 0;
1362             }
1363              
1364             =item C-Eis_rfc1918()>
1365              
1366             Returns true when C<$me> is an RFC 1918 address.
1367              
1368             10.0.0.0 - 10.255.255.255 (10/8 prefix)
1369             172.16.0.0 - 172.31.255.255 (172.16/12 prefix)
1370             192.168.0.0 - 192.168.255.255 (192.168/16 prefix)
1371              
1372             =cut
1373              
1374             my $ip_10 = NetAddr::IP::Lite->new('10.0.0.0/8');
1375             my $ip_10n = $ip_10->{addr}; # already the right value
1376             my $ip_10b = $ip_10n | ~ $ip_10->{mask};
1377              
1378             my $ip_172 = NetAddr::IP::Lite->new('172.16.0.0/12');
1379             my $ip_172n = $ip_172->{addr}; # already the right value
1380             my $ip_172b = $ip_172n | ~ $ip_172->{mask};
1381              
1382             my $ip_192 = NetAddr::IP::Lite->new('192.168.0.0/16');
1383             my $ip_192n = $ip_192->{addr}; # already the right value
1384             my $ip_192b = $ip_192n | ~ $ip_192->{mask};
1385              
1386             sub is_rfc1918 ($) {
1387 0     0 1 0 my $netme = $_[0]->{addr} & $_[0]->{mask};
1388 0         0 my $brdme = $_[0]->{addr} | ~ $_[0]->{mask};
1389 0 0 0     0 return 1 if (sub128($netme,$ip_10n) && sub128($ip_10b,$brdme));
1390 0 0 0     0 return 1 if (sub128($netme,$ip_192n) && sub128($ip_192b,$brdme));
1391 0 0 0     0 return (sub128($netme,$ip_172n) && sub128($ip_172b,$brdme))
1392             ? 1 : 0;
1393             }
1394              
1395             =item C<-Efirst()>
1396              
1397             Returns a new object representing the first usable IP address within
1398             the subnet (ie, the first host address).
1399              
1400             =cut
1401              
1402             my $_cidr127 = pack('N4',0xffffffff,0xffffffff,0xffffffff,0xfffffffe);
1403              
1404             sub first ($) {
1405 16 50   16 1 109 if (hasbits($_[0]->{mask} ^ $_cidr127)) {
1406 16         55 return $_[0]->network + 1;
1407             } else {
1408 0         0 return $_[0]->network;
1409             }
1410             # return $_[0]->network + 1;
1411             }
1412              
1413             =item C<-Elast()>
1414              
1415             Returns a new object representing the last usable IP address within
1416             the subnet (ie, one less than the broadcast address).
1417              
1418             =cut
1419              
1420             sub last ($) {
1421 3 50   3 1 17 if (hasbits($_[0]->{mask} ^ $_cidr127)) {
1422 3         10 return $_[0]->broadcast - 1;
1423             } else {
1424 0         0 return $_[0]->broadcast;
1425             }
1426             # return $_[0]->broadcast - 1;
1427             }
1428              
1429             =item C<-Enth($index)>
1430              
1431             Returns a new object representing the I-th usable IP address within
1432             the subnet (ie, the I-th host address). If no address is available
1433             (for example, when the network is too small for C<$index> hosts),
1434             C is returned.
1435              
1436             Version 4.00 of NetAddr::IP and version 1.00 of NetAddr::IP::Lite implements
1437             C<-Enth($index)> and C<-Enum()> exactly as the documentation states.
1438             Previous versions behaved slightly differently and not in a consistent
1439             manner.
1440              
1441             To use the old behavior for C<-Enth($index)> and C<-Enum()>:
1442              
1443             use NetAddr::IP::Lite qw(:old_nth);
1444              
1445             old behavior:
1446             NetAddr::IP->new('10/32')->nth(0) == undef
1447             NetAddr::IP->new('10/32')->nth(1) == undef
1448             NetAddr::IP->new('10/31')->nth(0) == undef
1449             NetAddr::IP->new('10/31')->nth(1) == 10.0.0.1/31
1450             NetAddr::IP->new('10/30')->nth(0) == undef
1451             NetAddr::IP->new('10/30')->nth(1) == 10.0.0.1/30
1452             NetAddr::IP->new('10/30')->nth(2) == 10.0.0.2/30
1453             NetAddr::IP->new('10/30')->nth(3) == 10.0.0.3/30
1454              
1455             Note that in each case, the broadcast address is represented in the
1456             output set and that the 'zero'th index is alway undef except for
1457             a point-to-point /31 or /127 network where there are exactly two
1458             addresses in the network.
1459              
1460             new behavior:
1461             NetAddr::IP->new('10/32')->nth(0) == 10.0.0.0/32
1462             NetAddr::IP->new('10.1/32'->nth(0) == 10.0.0.1/32
1463             NetAddr::IP->new('10/31')->nth(0) == 10.0.0.0/32
1464             NetAddr::IP->new('10/31')->nth(1) == 10.0.0.1/32
1465             NetAddr::IP->new('10/30')->nth(0) == 10.0.0.1/30
1466             NetAddr::IP->new('10/30')->nth(1) == 10.0.0.2/30
1467             NetAddr::IP->new('10/30')->nth(2) == undef
1468              
1469             Note that a /32 net always has 1 usable address while a /31 has exactly
1470             two usable addresses for point-to-point addressing. The first
1471             index (0) returns the address immediately following the network address
1472             except for a /31 or /127 when it return the network address.
1473              
1474             =cut
1475              
1476             sub nth ($$) {
1477 0     0 1 0 my $self = shift;
1478 0         0 my $count = shift;
1479              
1480 0         0 my $slash31 = ! hasbits($self->{mask} ^ $_cidr127);
1481 0 0       0 if ($Old_nth) {
    0          
1482 0 0 0     0 return undef if $slash31 && $count != 1;
1483 0 0 0     0 return undef if ($count < 1 or $count > $self->num ());
1484             }
1485             elsif ($slash31) {
1486 0 0 0     0 return undef if ($count && $count != 1); # only index 0, 1 allowed for /31
1487             } else {
1488 0         0 ++$count;
1489 0 0 0     0 return undef if ($count < 1 or $count > $self->num ());
1490             }
1491 0         0 return $self->network + $count;
1492             }
1493              
1494             =item C<-Enum()>
1495              
1496             As of version 4.42 of NetAddr::IP and version 1.27 of NetAddr::IP::Lite
1497             a /31 and /127 with return a net B value of 2 instead of 0 (zero)
1498             for point-to-point networks.
1499              
1500             Version 4.00 of NetAddr::IP and version 1.00 of NetAddr::IP::Lite
1501             return the number of usable IP addresses within the subnet,
1502             not counting the broadcast or network address.
1503              
1504             Previous versions worked only for ipV4 addresses, returned a
1505             maximum span of 2**32 and returned the number of IP addresses
1506             not counting the broadcast address.
1507             (one greater than the new behavior)
1508              
1509             To use the old behavior for C<-Enth($index)> and C<-Enum()>:
1510              
1511             use NetAddr::IP::Lite qw(:old_nth);
1512              
1513             WARNING:
1514              
1515             NetAddr::IP will calculate and return a numeric string for network
1516             ranges as large as 2**128. These values are TEXT strings and perl
1517             can treat them as integers for numeric calculations.
1518              
1519             Perl on 32 bit platforms only handles integer numbers up to 2**32
1520             and on 64 bit platforms to 2**64.
1521              
1522             If you wish to manipulate numeric strings returned by NetAddr::IP
1523             that are larger than 2**32 or 2**64, respectively, you must load
1524             additional modules such as Math::BigInt, bignum or some similar
1525             package to do the integer math.
1526              
1527             =cut
1528              
1529             sub num ($) {
1530 4608 100   4608 1 8765 if ($Old_nth) {
1531 2304         5325 my @net = unpack('L3N',$_[0]->{mask} ^ Ones);
1532             # number of ip's less broadcast
1533 2304 50 33     11379 return 0xfffffffe if $net[0] || $net[1] || $net[2]; # 2**32 -1
      33        
1534 2304 50       71436 return $net[3] if $net[3];
1535             } else { # returns 1 for /32 /128, 2 for /31 /127 else n-2 up to 2**32
1536 2304         8935 (undef, my $net) = addconst($_[0]->{mask},1);
1537 2304 50       66233 return 1 unless hasbits($net); # ipV4/32 or ipV6/128
1538 0         0 $net = $net ^ Ones;
1539 0 0       0 return 2 unless hasbits($net); # ipV4/31 or ipV6/127
1540 0 0       0 $net &= $_v4net unless $_[0]->{isv6};
1541 0         0 return bin2bcd($net);
1542             }
1543             }
1544              
1545             # deprecated
1546             #sub num ($) {
1547             # my @net = unpack('L3N',$_[0]->{mask} ^ Ones);
1548             # if ($Old_nth) {
1549             ## number of ip's less broadcast
1550             # return 0xfffffffe if $net[0] || $net[1] || $net[2]; # 2**32 -1
1551             # return $net[3] if $net[3];
1552             # } else { # returns 1 for /32 /128, 0 for /31 /127 else n-2 up to 2**32
1553             ## number of usable IP's === number of ip's less broadcast & network addys
1554             # return 0xfffffffd if $net[0] || $net[1] || $net[2]; # 2**32 -2
1555             # return 1 unless $net[3];
1556             # $net[3]--;
1557             # }
1558             # return $net[3];
1559             #}
1560              
1561             =pod
1562              
1563             =back
1564              
1565             =cut
1566              
1567             sub import {
1568 31 50   31   78 if (grep { $_ eq ':aton' } @_) {
  186         411  
1569 0         0 $Accept_Binary_IP = 1;
1570 0         0 @_ = grep { $_ ne ':aton' } @_;
  0         0  
1571             }
1572 31 50       80 if (grep { $_ eq ':old_nth' } @_) {
  186         577  
1573 0         0 $Old_nth = 1;
1574 0         0 @_ = grep { $_ ne ':old_nth' } @_;
  0         0  
1575             }
1576 31 50       59 if (grep { $_ eq ':lower' } @_)
  186         355  
1577             {
1578 0         0 NetAddr::IP::Util::lower();
1579 0         0 @_ = grep { $_ ne ':lower' } @_;
  0         0  
1580             }
1581 31 50       61 if (grep { $_ eq ':upper' } @_)
  186         376  
1582             {
1583 0         0 NetAddr::IP::Util::upper();
1584 0         0 @_ = grep { $_ ne ':upper' } @_;
  0         0  
1585             }
1586 31 50       56 if (grep { $_ eq ':nofqdn' } @_)
  186         421  
1587             {
1588 0         0 $NoFQDN = 1;
1589 0         0 @_ = grep { $_ ne ':nofqdn' } @_;
  0         0  
1590             }
1591 31         6717 NetAddr::IP::Lite->export_to_level(1, @_);
1592             }
1593              
1594             =head1 EXPORT_OK
1595              
1596             Zeros
1597             Ones
1598             V4mask
1599             V4net
1600             :aton DEPRECATED
1601             :old_nth
1602             :upper
1603             :lower
1604             :nofqdn
1605              
1606             =head1 AUTHORS
1607              
1608             Luis E. Muñoz Eluismunoz@cpan.orgE,
1609             Michael Robinton Emichael@bizsystems.comE
1610              
1611             =head1 WARRANTY
1612              
1613             This software comes with the same warranty as perl itself (ie, none),
1614             so by using it you accept any and all the liability.
1615              
1616             =head1 COPYRIGHT
1617              
1618             This software is (c) Luis E. Muñoz, 1999 - 2005
1619             and (c) Michael Robinton, 2006 - 2014.
1620              
1621             All rights reserved.
1622              
1623             This program is free software; you can redistribute it and/or modify
1624             it under the terms of either:
1625              
1626             a) the GNU General Public License as published by the Free
1627             Software Foundation; either version 2, or (at your option) any
1628             later version, or
1629              
1630             b) the "Artistic License" which comes with this distribution.
1631              
1632             This program is distributed in the hope that it will be useful,
1633             but WITHOUT ANY WARRANTY; without even the implied warranty of
1634             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
1635             the GNU General Public License or the Artistic License for more details.
1636              
1637             You should have received a copy of the Artistic License with this
1638             distribution, in the file named "Artistic". If not, I'll be glad to provide
1639             one.
1640              
1641             You should also have received a copy of the GNU General Public License
1642             along with this program in the file named "Copying". If not, write to the
1643              
1644             Free Software Foundation, Inc.,
1645             51 Franklin Street, Fifth Floor
1646             Boston, MA 02110-1301 USA
1647              
1648             or visit their web page on the internet at:
1649              
1650             http://www.gnu.org/copyleft/gpl.html.
1651              
1652             =head1 SEE ALSO
1653              
1654             NetAddr::IP(3), NetAddr::IP::Util(3), NetAddr::IP::InetBase(3)
1655              
1656             =cut
1657              
1658             1;