File Coverage

blib/lib/Net/IPAM/Util.pm
Criterion Covered Total %
statement 79 79 100.0
branch 32 34 94.1
condition 7 9 77.7
subroutine 16 16 100.0
pod 4 4 100.0
total 138 142 97.1


line stmt bran cond sub pod time code
1             package Net::IPAM::Util;
2              
3 10     10   127 use 5.10.0;
  10         32  
4 10     10   55 use strict;
  10         15  
  10         201  
5 10     10   47 use warnings;
  10         17  
  10         289  
6 10     10   48 use utf8;
  10         16  
  10         47  
7              
8 10     10   191 use Carp ();
  10         17  
  10         111  
9 10     10   40 use Socket ();
  10         19  
  10         179  
10              
11 10     10   56 use Exporter 'import';
  10         17  
  10         4616  
12             our @EXPORT_OK = qw(incr_n decr_n inet_ntop_pp inet_pton_pp);
13              
14             =head1 NAME
15              
16             Net::IPAM::Util - A selection of general utility subroutines for Net::IPAM
17              
18             =head1 SYNOPSIS
19              
20             use Net::IPAM::Util qw(incr_n inet_ntop_pp inet_pton_pp);
21              
22             $n = incr_n("\x0a\x00\x00\x01"); # 10.0.0.2
23             $n = incr_n( pack( 'n8', 0x2001, 0xdb8, 0, 0, 0, 0, 0, 1 ) ); # 2001:db8::2
24              
25             $n = decr_n("\x0a\x00\x00\x01"); # 10.0.0.0
26             $n = decr_n( pack( 'n8', 0x2001, 0xdb8, 0, 0, 0, 0, 0, 1 ) ); # 2001:db8::
27              
28             $n = inet_pton_pp( AF_INET6, '2001:db8::fe1' );
29             say inet_ntop_pp( AF_INET, "\x0a\x00\x00\x01" ); # 10.0.0.1
30              
31             =cut
32              
33             =head1 FUNCTIONS
34              
35             =head2 $address_plusplus = incr_n( $address )
36              
37             Increment a packed IPv4 or IPv6 address in network byte order. Returns undef on overflow.
38              
39             This increment function is needed in L and L for transparent handling
40             of IPv4 and IPv6 addresses and blocks.
41              
42             No need for L, this pure perl algorithm works for all uint_n in network byte order,
43             where n is a multiple of 32: uint_32, uint_64, uint_96, uint_128, ...
44              
45             =cut
46              
47             sub incr_n {
48 13   66 13 1 1323 my $n = shift // Carp::croak("missing argument");
49              
50             # split in individual 32 bit unsigned ints in network byte order
51 12         47 my @N = unpack( 'N*', $n );
52              
53             # start at least significant N
54 12         22 my $i = $#N;
55              
56             # carry?
57 12         34 while ( $N[$i] == 0xffff_ffff ) {
58              
59             # OVERFLOW, it's already the most significant N
60 14 100       37 return if $i == 0;
61              
62             # set this N to zero: 0xffff_ffff + 1 = 0x0000_0000 + carry
63 9         12 $N[$i] = 0;
64              
65             # carry on to next more significant N
66 9         15 $i--;
67             }
68              
69             # incr this N
70 7         10 $N[$i]++;
71              
72             # pack again the individual 32 bit integers in network byte order to one byte string
73 7         45 return pack( 'N*', @N );
74             }
75              
76             =head2 $address_minusminus = decr_n( $address )
77              
78             Decrement a packed IPv4 or IPv6 address in network byte order. Returns undef on underflow.
79              
80             This decrement function is needed in L and L for transparent handling
81             of IPv4 and IPv6 addresses and blocks.
82              
83             No need for L, this pure perl algorithm works for all uint_n in network byte order,
84             where n is a multiple of 32: uint_32, uint_64, uint_96, uint_128, ...
85              
86             =cut
87              
88             sub decr_n {
89 12   66 12 1 1629 my $n = shift // Carp::croak("missing argument");
90              
91             # split in individual 32 bit unsigned ints in network byte order
92 11         37 my @N = unpack( 'N*', $n );
93              
94             # start at least significant N
95 11         16 my $i = $#N;
96              
97             # carry?
98 11         30 while ( $N[$i] == 0 ) {
99              
100             # UNDERFLOW, it's already the most significant N
101 14 100       35 return if $i == 0;
102              
103             # set this N to ffff_ffff: 0 - 1 = 0xffff_ffff + carry
104 9         13 $N[$i] = 0xffff_ffff;
105              
106             # carry on to next more significant N
107 9         17 $i--;
108             }
109              
110             # decr this N
111 6         10 $N[$i]--;
112              
113             # pack again the individual 32 bit integers in network byte order to one byte string
114 6         33 return pack( 'N*', @N );
115             }
116              
117             =head2 $string = inet_ntop_pp( $family, $address )
118              
119             A pure perl implementation for (buggy) Socket::inet_ntop.
120              
121             Takes an address family (C or C) and
122             a packed binary address structure and translates it
123             into a human-readable textual representation of the address.
124              
125             =cut
126              
127             sub inet_ntop_pp {
128              
129             # modify @_ = (AF_INETx, $ip) => @_ = ($ip)
130 19     19 1 27 my $v = shift;
131 19 100       44 goto &_inet_ntop_v4_pp if $v == Socket::AF_INET;
132 11         30 goto &_inet_ntop_v6_pp;
133             }
134              
135             =head2 $address = inet_pton_pp( $family, $string )
136              
137             A pure perl implementation for (buggy) Socket::inet_pton.
138              
139             Takes an address family (C or C) and a string
140             containing a textual representation of an address in that family and
141             translates that to an packed binary address structure.
142              
143             =cut
144              
145             sub inet_pton_pp {
146              
147             # modify @_ = (AF_INETx, $ip) => @_ = ($ip)
148 72     72 1 100 my $v = shift;
149 72 100       168 goto &_inet_pton_v4_pp if $v == Socket::AF_INET;
150 48         139 goto &_inet_pton_v6_pp;
151             }
152              
153             # easy peasy
154             sub _inet_ntop_v4_pp {
155 8 50   8   20 return if length( $_[0] ) != 4;
156 8         65 return join( '.', unpack( 'C4', $_[0] ) );
157             }
158              
159             # (1) Hexadecimal digits are expressed as lower-case letters.
160             # For example, 2001:db8::1 is preferred over 2001:DB8::1.
161             #
162             # (2) Leading zeros in each 16-bit field are suppressed.
163             # For example, 2001:0db8::0001 is rendered as 2001:db8::1,
164             # though any all-zero field that is explicitly presented is rendered as 0.
165             #
166             # (3) Representations are shortened as much as possible.
167             # The longest sequence of consecutive all-zero fields is replaced with double-colon.
168             # If there are multiple longest runs of all-zero fields, then it is the leftmost that is compressed.
169             # E.g., 2001:db8:0:0:1:0:0:1 is rendered as 2001:db8::1:0:0:1 rather than as 2001:db8:0:0:1::1.
170             #
171             # (4) "::" is not used to shorten just a single 0 field.
172             # For example, 2001:db8:0:0:0:0:2:1 is shortened to 2001:db8::2:1,
173             # but 2001:db8:0000:1:1:1:1:1 is rendered as 2001:db8:0:1:1:1:1:1.
174             #
175             sub _inet_ntop_v6_pp {
176 11     11   21 my $n = shift;
177 11 50       24 return if length($n) != 16;
178              
179             # expand binary to hex, lower case, rule (1), leading zeroes squashed
180             # add : at left and right for symmetric squashing algo, see below
181             # :2001:db8:85a3:0:0:8a2e:370:7334:
182 11         72 my $ip = sprintf( ':%x:%x:%x:%x:%x:%x:%x:%x:', unpack( 'n8', $n ) );
183              
184             # rule (3,4) # squash the longest sequence of consecutive all-zero fields
185             # e.g. :0:0: (?!not followed) :0\1
186 11         74 $ip =~ s/(:0[:0]+:) (?! .+ :0\1)/::/x;
187              
188 11 100       60 $ip =~ s/^:// unless $ip =~ /^::/; # trim additional left
189 11 100       50 $ip =~ s/:$// unless $ip =~ /::$/; # trim additional right
190 11         31 return $ip;
191             }
192              
193             sub _inet_pton_v4_pp {
194              
195             # 'C' may overflow for values > 255, check below
196 10     10   69 no warnings qw(pack numeric);
  10         20  
  10         3442  
197 24     24   133 my $n = pack( 'C4', split( /\./, $_[0] ) );
198              
199             # unpack(pack...) must be idempotent
200             # check for overflow errors or leading zeroes
201 24 100       129 return unless $_[0] eq join( '.', unpack( 'C4', $n ) );
202              
203 14         37 return $n;
204             }
205              
206             sub _inet_pton_v6_pp {
207 48     48   67 my $ip = shift;
208              
209 48 100       148 return if $ip =~ m/[^a-fA-F0-9:]/;
210 46 100       113 return if $ip =~ m/:::/;
211              
212             # starts with just one colon: :cafe...
213 42 100       88 return if $ip =~ m/^:[^:]/;
214              
215             # ends with just one colon: ..:cafe:affe:
216 40 100       80 return if $ip =~ m/[^:]:$/;
217              
218 38         65 my $col_count = $ip =~ tr/://;
219 38         118 my $dbl_col_count = $ip =~ s/::/::/g;
220              
221 38 100       75 return if $col_count > 7;
222 34 100       61 return if $dbl_col_count > 1;
223 28 100 100     75 return if $dbl_col_count == 0 && $col_count != 7;
224              
225             # normalize for splitting, prepend or append 0
226 24         46 $ip =~ s/^:: /0::/x;
227 24         47 $ip =~ s/ ::$/::0/x;
228              
229             # expand ::
230 24         61 my $expand_dbl_col = ':0' x ( 8 - $col_count ) . ':';
231 24         55 $ip =~ s/::/$expand_dbl_col/;
232              
233 24         90 my @hextets = split( /:/, $ip );
234 24 100       46 return if grep { length > 4 } @hextets;
  192         306  
235              
236 22         32 my $n = pack( 'n8', map { hex } @hextets );
  176         276  
237 22         62 return $n;
238             }
239              
240             =head1 AUTHOR
241              
242             Karl Gaissmaier, C<< >>
243              
244             =head1 BUGS
245              
246             Please report any bugs or feature requests to C, or through
247             the web interface at L.
248             I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
249              
250             =head1 SUPPORT
251              
252             You can find documentation for this module with the perldoc command.
253              
254             perldoc Net::IPAM::Util
255              
256             You can also look for information at:
257              
258             =over 4
259              
260             =item * on github
261              
262             TODO
263              
264             =back
265              
266             =head1 SEE ALSO
267              
268             L
269             L
270             L
271              
272             =head1 LICENSE AND COPYRIGHT
273              
274             This software is copyright (c) 2020 by Karl Gaissmaier.
275              
276             This is free software; you can redistribute it and/or modify it under
277             the same terms as the Perl 5 programming language system itself.
278              
279             =cut
280              
281             1; # End of Net::IPAM::Util