File Coverage

blib/lib/NetAddr/IP/Util.pm
Criterion Covered Total %
statement 24 48 50.0
branch 1 18 5.5
condition 0 6 0.0
subroutine 8 14 57.1
pod 4 4 100.0
total 37 90 41.1


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2             package NetAddr::IP::Util;
3              
4 32     32   132 use strict;
  32         35  
  32         1000  
5             #use diagnostics;
6             #use lib qw(blib/lib);
7              
8 32     32   112 use vars qw($VERSION @EXPORT_OK @ISA %EXPORT_TAGS $Mode);
  32         37  
  32         2206  
9 32     32   127 use AutoLoader qw(AUTOLOAD);
  32         36  
  32         145  
10 32     32   11294 use NetAddr::IP::Util_IS;
  32         54  
  32         891  
11 32         150 use NetAddr::IP::InetBase qw(
12             :upper
13             :all
14 32     32   137 );
  32         59  
15              
16             *NetAddr::IP::Util::upper = \&NetAddr::IP::InetBase::upper;
17             *NetAddr::IP::Util::lower = \&NetAddr::IP::InetBase::lower;
18              
19             require DynaLoader;
20             require Exporter;
21              
22             @ISA = qw(Exporter DynaLoader);
23              
24             $VERSION = do { my @r = (q$Revision: 1.53 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
25              
26             @EXPORT_OK = qw(
27             inet_aton
28             inet_ntoa
29             ipv6_aton
30             ipv6_ntoa
31             ipv6_n2x
32             ipv6_n2d
33             inet_any2n
34             hasbits
35             isIPv4
36             isNewIPv4
37             isAnyIPv4
38             inet_n2dx
39             inet_n2ad
40             inet_pton
41             inet_ntop
42             inet_4map6
43             shiftleft
44             addconst
45             add128
46             sub128
47             notcontiguous
48             bin2bcd
49             bcd2bin
50             mode
51             ipv4to6
52             mask4to6
53             ipanyto6
54             maskanyto6
55             ipv6to4
56             bin2bcdn
57             bcdn2txt
58             bcdn2bin
59             simple_pack
60             comp128
61             packzeros
62             AF_INET
63             AF_INET6
64             naip_gethostbyname
65             havegethostbyname2
66             );
67              
68             %EXPORT_TAGS = (
69             all => [@EXPORT_OK],
70             inet => [qw(
71             inet_aton
72             inet_ntoa
73             ipv6_aton
74             ipv6_ntoa
75             ipv6_n2x
76             ipv6_n2d
77             inet_any2n
78             inet_n2dx
79             inet_n2ad
80             inet_pton
81             inet_ntop
82             inet_4map6
83             ipv4to6
84             mask4to6
85             ipanyto6
86             maskanyto6
87             ipv6to4
88             packzeros
89             naip_gethostbyname
90             )],
91             math => [qw(
92             shiftleft
93             hasbits
94             isIPv4
95             isNewIPv4
96             isAnyIPv4
97             addconst
98             add128
99             sub128
100             notcontiguous
101             bin2bcd
102             bcd2bin
103             )],
104             ipv4 => [qw(
105             inet_aton
106             inet_ntoa
107             )],
108             ipv6 => [qw(
109             ipv6_aton
110             ipv6_ntoa
111             ipv6_n2x
112             ipv6_n2d
113             inet_any2n
114             inet_n2dx
115             inet_n2ad
116             inet_pton
117             inet_ntop
118             inet_4map6
119             ipv4to6
120             mask4to6
121             ipanyto6
122             maskanyto6
123             ipv6to4
124             packzeros
125             naip_gethostbyname
126             )],
127             );
128              
129             if (NetAddr::IP::Util_IS->not_pure) {
130             eval { ## attempt to load 'C' version of utilities
131             bootstrap NetAddr::IP::Util $VERSION;
132             };
133             }
134             if (NetAddr::IP::Util_IS->pure || $@) { ## load the pure perl version if 'C' lib missing
135             require NetAddr::IP::UtilPP;
136             import NetAddr::IP::UtilPP qw( :all );
137             # require Socket;
138             # import Socket qw(inet_ntoa);
139             # *yinet_aton = \&Socket::inet_aton;
140             $Mode = 'Pure Perl';
141             }
142             else {
143             $Mode = 'CC XS';
144             }
145              
146             # if Socket lib is broken in some way, check for overange values
147             #
148             #my $overange = yinet_aton('256.1') ? 1:0;
149             #my $overange = gethostbyname('256.1') ? 1:0;
150              
151 0     0 1 0 sub mode() { $Mode };
152              
153             my $_newV4compat = pack('N4',0,0,0xffff,0);
154              
155             sub inet_4map6 {
156 0     0 1 0 my $naddr = shift;
157 0 0       0 if (length($naddr) == 4) {
    0          
158 0         0 $naddr = ipv4to6($naddr);
159             }
160             elsif (length($naddr) == 16) {
161             ; # is OK
162 0 0       0 return undef unless isAnyIPv4($naddr);
163             } else {
164 0         0 return undef;
165             }
166 0         0 $naddr |= $_newV4compat;
167 0         0 return $naddr;
168             }
169              
170       0     sub DESTROY {};
171              
172             my $havegethostbyname2 = 0;
173              
174             my $mygethostbyname;
175              
176             my $_Sock6ok = 1; # for testing gethostbyname
177              
178             sub havegethostbyname2 {
179 0 0   0 1 0 return $_Sock6ok
180             ? $havegethostbyname2
181             : 0;
182             }
183              
184             sub import {
185 65 50   65   137 if (grep { $_ eq ':noSock6' } @_) {
  802         993  
186 0         0 $_Sock6ok = 0;
187 0         0 @_ = grep { $_ ne ':noSock6' } @_;
  0         0  
188             }
189 65         11491 NetAddr::IP::Util->export_to_level(1,@_);
190             }
191              
192             package NetAddr::IP::UtilPolluted;
193              
194             # Socket pollutes the name space with all of its symbols. Since
195             # we don't want them all, confine them to this name space.
196              
197 32     32   160 use strict;
  32         82  
  32         701  
198 32     32   121 use Socket;
  32         33  
  32         28761  
199              
200             my $_v4zero = pack('L',0);
201             my $_zero = pack('L4',0,0,0,0);
202              
203             # invoke replacement subroutine for Perl's "gethostbyname"
204             # if Socket6 is available.
205             #
206             # NOTE: in certain BSD implementations, Perl's gethostbyname is broken
207             # we will use our own InetBase::inet_aton instead
208              
209             sub _end_gethostbyname {
210             # my ($name,$aliases,$addrtype,$length,@addrs) = @_;
211 0     0     my @rv = @_;
212             # first ip address = rv[4]
213 0           my $tip = $rv[4];
214 0 0 0       unless ($tip && $tip ne $_v4zero && $tip ne $_zero) {
    0 0        
    0          
215 0           @rv = ();
216             }
217             # length = rv[3]
218             elsif ($rv[3] && $rv[3] == 4) {
219 0           foreach (4..$#rv) {
220 0           $rv[$_] = NetAddr::IP::Util::inet_4map6(NetAddr::IP::Util::ipv4to6($rv[$_]));
221             }
222 0           $rv[3] = 16; # unconditionally set length to 16
223             }
224             elsif ($rv[3] == 16) {
225             ; # is ok
226             } else {
227 0           @rv = ();
228             }
229 0           return @rv;
230             }
231              
232             unless ( eval { require Socket6 }) {
233             $mygethostbyname = sub {
234             # SEE NOTE above about broken BSD
235             my @tip = gethostbyname(NetAddr::IP::InetBase::fillIPv4($_[0]));
236             return &_end_gethostbyname(@tip);
237             };
238             } else {
239             import Socket6 qw( gethostbyname2 getipnodebyname );
240             my $try = eval { my @try = gethostbyname2('127.0.0.1',NetAddr::IP::Util::AF_INET()); $try[4] };
241             if (! $@ && $try && $try eq INADDR_LOOPBACK()) {
242             *_ghbn2 = \&Socket6::gethostbyname2;
243             $havegethostbyname2 = 1;
244             } else {
245             *_ghbn2 = sub { return () }; # use failure branch below
246             }
247              
248             $mygethostbyname = sub {
249             my @tip;
250             unless ($_Sock6ok && (@tip = _ghbn2($_[0],NetAddr::IP::Util::AF_INET6())) && @tip > 1) {
251             # SEE NOTE above about broken BSD
252             @tip = gethostbyname(NetAddr::IP::InetBase::fillIPv4($_[0]));
253             }
254             return &_end_gethostbyname(@tip);
255             };
256             }
257              
258             package NetAddr::IP::Util;
259              
260             sub naip_gethostbyname {
261             # turn off complaint from Socket6 about missing numeric argument
262 0     0 1   undef local $^W;
263 0           my @rv = &$mygethostbyname($_[0]);
264             return wantarray
265             ? @rv
266 0 0         : $rv[4];
267             }
268              
269             1;
270              
271             __END__