File Coverage

blib/lib/Net/IP/XS.pm
Criterion Covered Total %
statement 36 59 61.0
branch 0 8 0.0
condition n/a
subroutine 22 26 84.6
pod 4 17 23.5
total 62 110 56.3


line stmt bran cond sub pod time code
1             package Net::IP::XS;
2              
3 44     44   2656345 use warnings;
  44         516  
  44         2152  
4 44     44   279 use strict;
  44         97  
  44         1054  
5              
6 44     44   986 use 5.006;
  44         160  
7              
8 44     44   36876 use Math::BigInt;
  44         1188764  
  44         1212  
9 44     44   1003391 use Tie::Simple;
  44         389620  
  44         7255  
10              
11             our $VERSION = '0.20';
12              
13             our $IP_NO_OVERLAP = 0;
14             our $IP_PARTIAL_OVERLAP = 1;
15             our $IP_A_IN_B_OVERLAP = -1;
16             our $IP_B_IN_A_OVERLAP = -2;
17             our $IP_IDENTICAL = -3;
18              
19             our @EXPORT_OK = qw(Error
20             Errno
21             ip_iptobin
22             ip_bintoip
23             ip_iplengths
24             ip_bintoint
25             ip_inttobin
26             ip_expand_address
27             ip_is_ipv4
28             ip_is_ipv6
29             ip_get_version
30             ip_get_mask
31             ip_last_address_bin
32             ip_splitprefix
33             ip_is_valid_mask
34             ip_bincomp
35             ip_binadd
36             ip_get_prefix_length
37             ip_compress_v4_prefix
38             ip_is_overlap
39             ip_check_prefix
40             ip_range_to_prefix
41             ip_get_embedded_ipv4
42             ip_aggregate
43             ip_prefix_to_range
44             ip_reverse
45             ip_normalize
46             ip_compress_address
47             ip_iptype
48             ip_auth
49             ip_normal_range
50             $IP_NO_OVERLAP
51             $IP_PARTIAL_OVERLAP
52             $IP_A_IN_B_OVERLAP
53             $IP_B_IN_A_OVERLAP
54             $IP_IDENTICAL);
55              
56             our %EXPORT_TAGS = (PROC => [@EXPORT_OK]);
57              
58             use overload (
59             '+' => 'ip_add_num',
60 777     777   136016 'bool' => sub { @_ },
61 44     44   380 );
  44         93  
  44         483  
62              
63 44     44   4350 use base qw(DynaLoader Exporter);
  44         103  
  44         9427  
64             __PACKAGE__->bootstrap($VERSION);
65              
66             our $ERROR;
67             our $ERRNO;
68              
69             BEGIN {
70 44     44   424 tie $ERROR, 'Tie::Simple', 1, FETCH => \&ip_get_Error,
71             STORE => \&ip_set_Error;
72 44         755 tie $ERRNO, 'Tie::Simple', 1, FETCH => \&ip_get_Errno,
73             STORE => \&ip_set_Errno;
74             };
75              
76             our %IPv4ranges = (
77             '00000000' => 'PRIVATE', # 0/8
78             '00001010' => 'PRIVATE', # 10/8
79             '01111111' => 'PRIVATE', # 127.0/8
80             '101011000001' => 'PRIVATE', # 172.16/12
81             '1100000010101000' => 'PRIVATE', # 192.168/16
82             '1010100111111110' => 'RESERVED', # 169.254/16
83             '110000000000000000000010' => 'RESERVED', # 192.0.2/24
84             '1110' => 'RESERVED', # 224/4
85             '11110' => 'RESERVED', # 240/5
86             '11111' => 'RESERVED', # 248/5
87             );
88              
89             our %IPv6ranges = (
90             '00000000' => 'RESERVED', # ::/8
91             '00000001' => 'RESERVED', # 0100::/8
92             '0000001' => 'RESERVED', # 0200::/7
93             '000001' => 'RESERVED', # 0400::/6
94             '00001' => 'RESERVED', # 0800::/5
95             '0001' => 'RESERVED', # 1000::/4
96             '001' => 'GLOBAL-UNICAST', # 2000::/3
97             '010' => 'RESERVED', # 4000::/3
98             '011' => 'RESERVED', # 6000::/3
99             '100' => 'RESERVED', # 8000::/3
100             '101' => 'RESERVED', # A000::/3
101             '110' => 'RESERVED', # C000::/3
102             '1110' => 'RESERVED', # E000::/4
103             '11110' => 'RESERVED', # F000::/5
104             '111110' => 'RESERVED', # F800::/6
105             '1111101' => 'RESERVED', # FA00::/7
106             '1111110' => 'UNIQUE-LOCAL-UNICAST', # FC00::/7
107             '111111100' => 'RESERVED', # FE00::/9
108             '1111111010' => 'LINK-LOCAL-UNICAST', # FE80::/10
109             '1111111011' => 'RESERVED', # FEC0::/10
110             '11111111' => 'MULTICAST', # FF00::/8
111             '00100000000000010000110110111000' => 'RESERVED', # 2001:DB8::/32
112              
113             '0' x 96 => 'IPV4COMP', # ::/96
114             ('0' x 80) . ('1' x 16) => 'IPV4MAP', # ::FFFF:0:0/96
115              
116             '0' x 128 => 'UNSPECIFIED', # ::/128
117             ('0' x 127) . '1' => 'LOOPBACK' # ::1/128
118             );
119              
120 48     48 1 48510 sub Error { $ERROR }
121 51     51 0 41174 sub Errno { $ERRNO }
122              
123 10     10 1 12857 sub ip_bintoint { Math::BigInt->new(ip_bintoint_str($_[0])) }
124 13     13 1 6960 sub ip_inttobin { ip_inttobin_str(Math::BigInt->new($_[0]), $_[1]) }
125              
126 5     5 0 110653 sub binip { $_[0]->{'binip'} }
127 4     4 0 326 sub version { $_[0]->{'ipversion'} }
128 0     0 0 0 sub error { $_[0]->{'error'} }
129 0     0 0 0 sub errno { $_[0]->{'errno'} }
130 6     6 0 340 sub prefixlen { $_[0]->{'prefixlen'} }
131 9     9 0 3176 sub ip { $_[0]->{'ip'} }
132 4     4 0 332 sub is_prefix { $_[0]->{'is_prefix'} }
133 4     4 0 360 sub binmask { $_[0]->{'binmask'} }
134              
135 19     19 0 17602 sub size { Math::BigInt->new(size_str($_[0])) }
136 19     19 0 15684 sub intip { Math::BigInt->new(intip_str($_[0])) }
137 18     18 0 34149 sub last_int { Math::BigInt->new(last_int_str($_[0])) }
138              
139             sub auth
140             {
141 0     0 0   my ($self) = shift;
142              
143 0 0         return ($self->{auth}) if defined($self->{auth});
144              
145 0           my $auth = ip_auth($self->ip, $self->version);
146              
147 0 0         if (!$auth) {
148 0           $self->{error} = $ERROR;
149 0           $self->{errno} = $ERRNO;
150 0           return;
151             }
152              
153 0           $self->{auth} = $auth;
154              
155 0           return ($self->{auth});
156             }
157              
158             sub ip_auth
159             {
160 0     0 1   my ($ip, $ip_version) = (@_);
161              
162 0 0         if (not $ip_version) {
163 0           $ERROR = "Cannot determine IP version for $ip";
164 0           $ERRNO = 101;
165 0           return;
166             }
167              
168 0 0         if ($ip_version != 4) {
169 0           $ERROR = "Cannot get auth information: Not an IPv4 address";
170 0           $ERRNO = 308;
171 0           return;
172             }
173              
174 0           require IP::Authority;
175              
176 0           my $reg = new IP::Authority;
177              
178 0           return ($reg->inet_atoauth($ip));
179             }
180              
181             1;
182              
183             __END__