File Coverage

blib/lib/App/Manoc/Utils/IPAddress.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             package App::Manoc::Utils::IPAddress;
2             #ABSTRACT: collection of functions to handle IP addresses
3              
4 2     2   14061 use strict;
  2         5  
  2         48  
5 2     2   10 use warnings;
  2         4  
  2         64  
6             our $VERSION = '2.99.2'; ##TRIAL VERSION
7              
8 2     2   10 use Carp;
  2         4  
  2         112  
9 2     2   323 use Regexp::Common qw/net/;
  0            
  0            
10              
11             BEGIN {
12             use Exporter 'import';
13             our @EXPORT_OK = qw(
14             ip2int int2ip
15             netmask_prefix2range netmask2prefix
16             padded_ipaddr unpadded_ipaddr
17             prefix2wildcard prefix2netmask prefix2netmask_i
18             check_addr check_partial_addr check_ipv6_addr
19             );
20              
21             }
22              
23              
24             sub check_addr {
25             my $addr = shift;
26             return if ( !defined($addr) );
27             $addr =~ s/\s+//;
28             return $addr =~ /^$RE{net}{IPv4}$/;
29             # return $addr =~ /^(25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?\.?)((25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)){0,3}$/;
30             }
31              
32              
33             sub check_partial_addr {
34             my $addr = shift;
35             return if ( !defined($addr) );
36             $addr =~ s/\s+//;
37              
38             if ( $addr =~ /^([0-9\.]+\.)$/o or
39             $addr =~ /^(\.[0-9\.]+)$/o or
40             $addr =~ /^(?:[0-9]{1,3}\.){3}[0-9]{1,3}$/o )
41             {
42             return 1;
43             }
44             }
45              
46              
47             sub check_ipv6_addr {
48             die "Not implemented";
49             }
50              
51             my %INET_NETMASK = (
52             '000.000.000.000' => 0,
53             '128.000.000.000' => 1,
54             '192.000.000.000' => 2,
55             '224.000.000.000' => 3,
56             '240.000.000.000' => 4,
57             '248.000.000.000' => 5,
58             '252.000.000.000' => 6,
59             '254.000.000.000' => 7,
60             '255.000.000.000' => 8,
61             '255.128.000.000' => 9,
62             '255.192.000.000' => 10,
63             '255.224.000.000' => 11,
64             '255.240.000.000' => 12,
65             '255.248.000.000' => 13,
66             '255.252.000.000' => 14,
67             '255.254.000.000' => 15,
68             '255.255.000.000' => 16,
69             '255.255.128.000' => 17,
70             '255.255.192.000' => 18,
71             '255.255.224.000' => 19,
72             '255.255.240.000' => 20,
73             '255.255.248.000' => 21,
74             '255.255.252.000' => 22,
75             '255.255.254.000' => 23,
76             '255.255.255.000' => 24,
77             '255.255.255.128' => 25,
78             '255.255.255.192' => 26,
79             '255.255.255.224' => 27,
80             '255.255.255.240' => 28,
81             '255.255.255.248' => 29,
82             '255.255.255.252' => 30,
83             '255.255.255.254' => 31,
84             '255.255.255.255' => 32,
85             );
86              
87              
88             sub ip2int {
89             return unless defined( $_[0] );
90             return unpack( 'N', pack( 'C4', split( /\./, $_[0] ) ) );
91             }
92              
93              
94             sub int2ip {
95             return unless defined( $_[0] );
96             return join ".", unpack( "CCCC", pack( "N", $_[0] ) );
97             }
98              
99              
100             sub prefix2netmask_i {
101             my $prefix = shift;
102             ( $prefix >= 0 || $prefix <= 32 ) or
103             croak "Invalid subnet prefix";
104              
105             return $prefix ? ~( ( 1 << ( 32 - $prefix ) ) - 1 ) : 0;
106             }
107              
108              
109             sub prefix2netmask {
110             my $prefix = shift;
111             ( $prefix >= 0 || $prefix <= 32 ) or
112             croak "Invalid subnet prefix";
113             return int2ip( ~( ( 1 << ( 32 - $prefix ) ) - 1 ) );
114             }
115              
116              
117             sub prefix2wildcard {
118             @_ == 1 || croak "Missing prefix parameter";
119             my $prefix = shift;
120             ( $prefix >= 0 || $prefix <= 32 ) or
121             croak "Invalid subnet prefix";
122              
123             return int2ip( $prefix ? ( ( 1 << ( 32 - $prefix ) ) - 1 ) : 0xFFFFFFFF );
124             }
125              
126              
127             sub netmask2prefix {
128             my $netmask = shift || croak "Missing netmask parameter";
129             return $INET_NETMASK{ padded_ipaddr($netmask) };
130             }
131              
132              
133             sub padded_ipaddr {
134             my $addr = shift;
135             defined($addr) or return;
136             $addr =~ s/(^\.|\.$)//;
137             $addr ne "" and join( '.', map { sprintf( '%03d', $_ ) } split( /\./, $addr ) );
138             }
139              
140              
141             sub unpadded_ipaddr {
142             my $addr = shift;
143             join( '.', map { sprintf( '%d', $_ ) } split( /\./, $addr ) );
144             }
145              
146             1;
147              
148             __END__
149              
150             =pod
151              
152             =head1 NAME
153              
154             App::Manoc::Utils::IPAddress - collection of functions to handle IP addresses
155              
156             =head1 VERSION
157              
158             version 2.99.2
159              
160             =head1 FUNCTIONS
161              
162             =head2 check_addr($addr)
163              
164             Return true if C<$addr> is a valid IPv4 address string.
165              
166             =head2 check_partial_addr($addr)
167              
168             Return true if C<$addr> looks like a partial IPv4 address string.
169              
170             =head2 check_ipv6_addr
171              
172             NOT IMPLEMENTED YET
173              
174             =head2 ip2int
175              
176             Convert a string to an unsigned long (32-bit) in network order.
177              
178             =head2 int2ip
179              
180             Convert an unsigned long (32-bit) in network order to a dotted notation ipaddres
181              
182             =head2 prefix2netmask_i
183              
184             Convert a networkk prefix length to a netmask represented as an integer.
185              
186             =head2 prefix2netmask
187              
188             Convert a networkk prefix length to a netmask represented as a string.
189              
190             =head2 prefix2wildcard
191              
192             Convert a network prefix length to a network wildcard
193              
194             =head2 netmask2prefix
195              
196             Convert a network netmask (as an ipv4 address string) to prefix length.
197              
198             netmask2prefix("255.255.255.0"); # return 24
199              
200             Return undef if input is not a valid netmask.
201              
202             =head2 padded_ipaddr
203              
204             Return a zero padded representation of an IPv4 address string.
205              
206             padded_ipaddr("10.1.1.0"); # return "010.001.001.000"
207              
208             Useful when storing ip addresses as strings in databases.
209              
210             =head2 unpadded_ipaddr
211              
212             Remove zero padding from an IPv4 address string.
213              
214             =head1 AUTHORS
215              
216             =over 4
217              
218             =item *
219              
220             Gabriele Mambrini <gmambro@cpan.org>
221              
222             =item *
223              
224             Enrico Liguori
225              
226             =back
227              
228             =head1 COPYRIGHT AND LICENSE
229              
230             This software is copyright (c) 2017 by Gabriele Mambrini.
231              
232             This is free software; you can redistribute it and/or modify it under
233             the same terms as the Perl 5 programming language system itself.
234              
235             =cut