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 |