line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
=head1 NAME |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
Net::CIDR::Lookup |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
=head1 DESCRIPTION |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
This class implements a lookup table indexed by IPv4 networks or hosts. |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
=over 1 |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
=item Addresses are accepted in numeric form (integer with separate netbits argument), |
12
|
|
|
|
|
|
|
as strings in CIDR notation or as IP address ranges |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
=item Overlapping or adjacent networks are automatically coalesced if their |
15
|
|
|
|
|
|
|
associated values are equal. |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
=item The table is implemented as a binary tree so lookup and insertion take O(log n) |
18
|
|
|
|
|
|
|
time. |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
=back |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
Since V0.5, errors are signalled by an exception so method calls should generally by wrapped in an C. |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
=head1 SYNOPSIS |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
use Net::CIDR::Lookup; |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
$cidr = Net::CIDR::Lookup->new; |
29
|
|
|
|
|
|
|
$cidr->add("192.168.42.0/24",1); # Add first network, value 1 |
30
|
|
|
|
|
|
|
$cidr->add_num(167772448,27,2); # 10.0.1.32/27 => 2 |
31
|
|
|
|
|
|
|
$cidr->add("192.168.43.0/24",1); # Automatic coalescing to a /23 |
32
|
|
|
|
|
|
|
$cidr->add("192.168.41.0/24",2); # Stays separate due to different value |
33
|
|
|
|
|
|
|
$cidr->add("192.168.42.128/25",2); # Error: overlaps with different value |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
$val = $cidr->lookup("192.168.41.123"); # => 2 |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
$h = $cidr->to_hash; # Convert tree to a hash |
38
|
|
|
|
|
|
|
print "$k => $v\n" while(($k,$v) = each %$h); |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
# Output (order may vary): |
41
|
|
|
|
|
|
|
# 192.168.42.0/23 => 1 |
42
|
|
|
|
|
|
|
# 10.0.1.32/27 => 2 |
43
|
|
|
|
|
|
|
# 192.168.41.0/24 => 2 |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
$cidr->walk(sub { |
46
|
|
|
|
|
|
|
my ($addr, $bits, $val) = @_; |
47
|
|
|
|
|
|
|
print join('.', unpack 'C*', pack 'N', $addr), "/$bits => $val\n" |
48
|
|
|
|
|
|
|
} |
49
|
|
|
|
|
|
|
); |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
# Output (fixed order): |
52
|
|
|
|
|
|
|
# 10.0.1.32/27 => 2 |
53
|
|
|
|
|
|
|
# 192.168.41.0/24 => 2 |
54
|
|
|
|
|
|
|
# 192.168.42.0/23 => 1 |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
$cidr->clear; # Remove all entries |
57
|
|
|
|
|
|
|
$cidr->add_range('1.2.3.11 - 1.2.4.234', 42); # Add a range of addresses, |
58
|
|
|
|
|
|
|
# automatically split into CIDR blocks |
59
|
|
|
|
|
|
|
$h = $cidr->to_hash; |
60
|
|
|
|
|
|
|
print "$k => $v\n" while(($k,$v) = each %$h); |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
# Output (order may vary): |
63
|
|
|
|
|
|
|
# 1.2.4.128/26 => 42 |
64
|
|
|
|
|
|
|
# 1.2.3.32/27 => 42 |
65
|
|
|
|
|
|
|
# 1.2.3.64/26 => 42 |
66
|
|
|
|
|
|
|
# 1.2.4.234/32 => 42 |
67
|
|
|
|
|
|
|
# 1.2.4.0/25 => 42 |
68
|
|
|
|
|
|
|
# 1.2.3.12/30 => 42 |
69
|
|
|
|
|
|
|
# 1.2.3.128/25 => 42 |
70
|
|
|
|
|
|
|
# 1.2.3.16/28 => 42 |
71
|
|
|
|
|
|
|
# 1.2.4.224/29 => 42 |
72
|
|
|
|
|
|
|
# 1.2.4.232/31 => 42 |
73
|
|
|
|
|
|
|
# 1.2.3.11/32 => 42 |
74
|
|
|
|
|
|
|
# 1.2.4.192/27 => 42 |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
=head1 VERSION HISTORY |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
See L |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
=head1 METHODS |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
=cut |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
package Net::CIDR::Lookup; |
85
|
2
|
|
|
2
|
|
13139
|
use strict; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
41
|
|
86
|
2
|
|
|
2
|
|
30
|
use 5.008008; |
|
2
|
|
|
|
|
4
|
|
87
|
2
|
|
|
2
|
|
924
|
use integer; |
|
2
|
|
|
|
|
19
|
|
|
2
|
|
|
|
|
7
|
|
88
|
2
|
|
|
2
|
|
45
|
use Carp; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
99
|
|
89
|
2
|
|
|
2
|
|
503
|
use Socket qw/ inet_ntop inet_pton AF_INET /; |
|
2
|
|
|
|
|
2468
|
|
|
2
|
|
|
|
|
426
|
|
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
our $VERSION = '0.54'; |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
BEGIN { |
94
|
|
|
|
|
|
|
# IPv4 address from dotted-quad to integer |
95
|
|
|
|
|
|
|
# Choose manual implementation on Windows where inet_pton() is not available |
96
|
2
|
50
|
|
2
|
|
9
|
if('MSWin32' eq $^O) { |
97
|
|
|
|
|
|
|
*_dq2int = sub { ## no critic (Subroutines::RequireArgUnpacking) |
98
|
0
|
|
|
|
|
0
|
my @oct = split /\./, $_[0]; |
99
|
0
|
0
|
|
|
|
0
|
4 == @oct or croak "address must be in dotted-quad form, is `$_[0]'"; |
100
|
0
|
|
|
|
|
0
|
my $ip = 0; |
101
|
0
|
|
|
|
|
0
|
foreach(@oct) { |
102
|
0
|
0
|
0
|
|
|
0
|
$_ <= 255 and $_ >= 0 |
103
|
|
|
|
|
|
|
or croak "invalid component `$_' in address `$_[0]'"; |
104
|
0
|
|
|
|
|
0
|
$ip = $ip<<8 | $_; |
105
|
|
|
|
|
|
|
} |
106
|
0
|
|
|
|
|
0
|
return $ip; |
107
|
0
|
|
|
|
|
0
|
}; |
108
|
|
|
|
|
|
|
} else { |
109
|
2
|
|
|
47
|
|
1924
|
*_dq2int = sub { unpack 'N', inet_pton(AF_INET, shift) }; |
|
47
|
|
|
|
|
177
|
|
110
|
|
|
|
|
|
|
} |
111
|
|
|
|
|
|
|
} |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
=head2 new |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
Arguments: none |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
Return Value: new object |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
=cut |
120
|
|
|
|
|
|
|
|
121
|
24
|
|
|
24
|
1
|
23537
|
sub new { bless [], shift } |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
=head2 add |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
Arguments: C<$cidr>, C<$value> |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
Return Value: none |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
Adds VALUE to the tree under the key CIDR. CIDR must be a string containing an |
130
|
|
|
|
|
|
|
IPv4 address followed by a slash and a number of network bits. Bits to the |
131
|
|
|
|
|
|
|
right of this mask will be ignored. |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
=cut |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
sub add { |
136
|
30
|
|
|
30
|
1
|
1793
|
my ($self, $cidr, $val) = @_; |
137
|
|
|
|
|
|
|
|
138
|
30
|
50
|
|
|
|
50
|
defined $val or croak "can't store an undef"; |
139
|
|
|
|
|
|
|
|
140
|
30
|
|
|
|
|
143
|
my ($net, $bits) = $cidr =~ m{ ^ ([.[:digit:]]+) / (\d+) $ }ox; |
141
|
30
|
50
|
33
|
|
|
112
|
defined $net and defined $bits or croak 'CIDR syntax error: use /'; |
142
|
30
|
50
|
|
|
|
34
|
my $intnet = _dq2int($net) or return; |
143
|
30
|
|
|
|
|
52
|
$self->_add($intnet,$bits,$val); |
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
=head2 add_range |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
Arguments: C<$range>, C<$value> |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
Return Value: none |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
Adds VALUE to the tree for each address included in RANGE which must be a |
153
|
|
|
|
|
|
|
hyphenated range of IP addresses in dotted-quad format (e.g. |
154
|
|
|
|
|
|
|
"192.168.0.150-192.168.10.1") and with the first address being numerically |
155
|
|
|
|
|
|
|
smaller the second. This range will be split up into as many CIDR blocks as |
156
|
|
|
|
|
|
|
necessary (algorithm adapted from a script by Dr. Liviu Daia). |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
=cut |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
sub add_range { |
161
|
4
|
|
|
4
|
1
|
211
|
my ($self, $range, $val) = @_; |
162
|
|
|
|
|
|
|
|
163
|
4
|
50
|
|
|
|
7
|
defined $val or croak "can't store an undef"; |
164
|
|
|
|
|
|
|
|
165
|
4
|
|
|
|
|
22
|
my ($start, $end, $crud) = split /\s*-\s*/, $range; |
166
|
4
|
50
|
33
|
|
|
19
|
croak 'must have exactly one hyphen in range' |
167
|
|
|
|
|
|
|
if(defined $crud or not defined $end); |
168
|
|
|
|
|
|
|
|
169
|
4
|
|
|
|
|
7
|
$self->add_num_range(_dq2int($start), _dq2int($end), $val); |
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
=head2 add_num |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
Arguments: C<$address>, C<$bits>, C<$value> |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
Return Value: none |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
Like C but accepts address and bits as separate integer arguments |
179
|
|
|
|
|
|
|
instead of a string. |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
=cut |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
sub add_num { ## no critic (Subroutines::RequireArgUnpacking) |
184
|
|
|
|
|
|
|
# my ($self,$ip,$bits,$val) = @_; |
185
|
|
|
|
|
|
|
# Just call the recursive adder for now but allow for changes in object |
186
|
|
|
|
|
|
|
# representation ($self != $n) |
187
|
21
|
50
|
|
21
|
1
|
25
|
defined $_[3] or croak "can't store an undef"; |
188
|
21
|
|
|
|
|
19
|
_add(@_); |
189
|
|
|
|
|
|
|
} |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
=head2 add_num_range |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
Arguments: C<$start>, C<$end>, C<$value> |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
Return Value: none |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
Like C but accepts addresses as separate integer arguments instead |
198
|
|
|
|
|
|
|
of a range string. |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
=cut |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
sub add_num_range { |
203
|
4
|
|
|
4
|
1
|
5
|
my ($self, $start, $end, $val) = @_; |
204
|
4
|
|
|
|
|
2
|
my @chunks; |
205
|
|
|
|
|
|
|
|
206
|
4
|
50
|
|
|
|
9
|
$start > $end |
207
|
|
|
|
|
|
|
and croak sprintf "start > end in range %s--%s", _int2dq($start), _int2dq($end); |
208
|
|
|
|
|
|
|
|
209
|
4
|
|
|
|
|
7
|
_do_chunk(\@chunks, $start, $end, 31, 0); |
210
|
4
|
|
|
|
|
11
|
$self->add_num(@$_, $val) for(@chunks); |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
=head2 lookup |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
Arguments: C<$address> |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
Return Value: value assoiated with this address or C |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
Looks up an address and returns the value associated with the network |
220
|
|
|
|
|
|
|
containing it. So far there is no way to tell which network that is though. |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
=cut |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
sub lookup { |
225
|
9
|
|
|
9
|
1
|
17
|
my ($self, $addr) = @_; |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
# Make sure there is no network spec tacked onto $addr |
228
|
9
|
|
|
|
|
10
|
$addr =~ s!/.*!!; |
229
|
9
|
|
|
|
|
12
|
$self->_lookup(_dq2int($addr)); |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
=head2 lookup_num |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
Arguments: C<$address> |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
Return Value: value assoiated with this address or C |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
Like C but accepts the address in integer form. |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
=cut |
242
|
|
|
|
|
|
|
|
243
|
2
|
|
|
2
|
1
|
26
|
sub lookup_num { shift->_lookup($_[0]) } ## no critic (Subroutines::RequireArgUnpacking) |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
=head2 to_hash |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
Arguments: none |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
Return Value: C<$hashref> |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
Returns a hash representation of the tree with keys being CIDR-style network |
252
|
|
|
|
|
|
|
addresses. |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
=cut |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
sub to_hash { |
257
|
11
|
|
|
11
|
1
|
30
|
my ($self) = @_; |
258
|
11
|
|
|
|
|
9
|
my %result; |
259
|
|
|
|
|
|
|
$self->_walk(0, 0, sub { |
260
|
30
|
|
|
30
|
|
40
|
my $net = _int2dq($_[0]) . '/' . $_[1]; |
261
|
30
|
50
|
|
|
|
57
|
if(defined $result{$net}) { |
262
|
0
|
|
|
|
|
0
|
confess("internal error: network $net mapped to $result{$net} already!\n"); |
263
|
|
|
|
|
|
|
} else { |
264
|
30
|
|
|
|
|
92
|
$result{$net} = $_[2]; |
265
|
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
|
} |
267
|
11
|
|
|
|
|
45
|
); |
268
|
11
|
|
|
|
|
56
|
return \%result; |
269
|
|
|
|
|
|
|
} |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
=head2 walk |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
Arguments: C<$coderef> to call for each tree entry. Callback arguments are: |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
=over 1 |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
=item C<$address> |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
The network address in integer form |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
=item C<$bits> |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
The current CIDR block's number of network bits |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
=item C<$value> |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
The value associated with this block |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
=back |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
Return Value: none |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
=cut |
294
|
|
|
|
|
|
|
|
295
|
0
|
|
|
0
|
1
|
0
|
sub walk { $_[0]->_walk(0, 0, $_[1]) } ## no critic (Subroutines::RequireArgUnpacking) |
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
=head2 clear |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
Arguments: none |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
Return Value: none |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
Remove all entries from the tree. |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
=cut |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
sub clear { |
309
|
1
|
|
|
1
|
1
|
5
|
my $self = shift; |
310
|
1
|
|
|
|
|
7
|
undef @$self; |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
=head1 BUGS |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
=over 1 |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
=item |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
I didn't need deletions yet and deleting parts of a CIDR block is a bit more |
320
|
|
|
|
|
|
|
complicated than anything this class does so far, so it's not implemented. |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
=item |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
Storing an C value does not work and yields an error. This would be |
325
|
|
|
|
|
|
|
relatively easy to fix at the cost of some memory so that's more a design |
326
|
|
|
|
|
|
|
decision. |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
=back |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
=head1 AUTHORS, COPYRIGHTS & LICENSE |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
Matthias Bethke |
333
|
|
|
|
|
|
|
while working for 1&1 Internet AG |
334
|
|
|
|
|
|
|
|
335
|
|
|
|
|
|
|
Licensed unter the Artistic License 2.0 |
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
=head1 SEE ALSO |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
This module's methods are based loosely on those of C |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
=cut |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
# Walk through a subtree and insert a network |
344
|
|
|
|
|
|
|
sub _add { |
345
|
51
|
|
|
51
|
|
47
|
my ($node, $addr, $nbits, $val) = @_; |
346
|
51
|
|
|
|
|
37
|
my ($bit, $checksub); |
347
|
0
|
|
|
|
|
0
|
my @node_stack; |
348
|
|
|
|
|
|
|
|
349
|
|
|
|
|
|
|
DESCEND: |
350
|
51
|
|
|
|
|
34
|
while(1) { |
351
|
1242
|
100
|
|
|
|
1177
|
$bit = $addr & 0x80000000 ? 1 : 0; |
352
|
1242
|
|
|
|
|
645
|
$addr <<= 1; |
353
|
|
|
|
|
|
|
|
354
|
1242
|
100
|
|
|
|
1445
|
if(__PACKAGE__ ne ref $node) { |
355
|
4
|
100
|
|
|
|
23
|
return 1 if($val eq $node); # Compatible entry (tried to add a subnet of one already in the tree) |
356
|
1
|
|
|
|
|
20
|
croak "incompatible entry, found `$node' trying to add `$val'"; |
357
|
|
|
|
|
|
|
} |
358
|
1238
|
100
|
|
|
|
1368
|
last DESCEND unless --$nbits; |
359
|
1191
|
100
|
|
|
|
1067
|
if(defined $node->[$bit]) { |
360
|
661
|
|
|
|
|
426
|
$checksub = 1; |
361
|
|
|
|
|
|
|
} else { |
362
|
530
|
|
50
|
|
|
1153
|
$node->[$bit] ||= bless([], __PACKAGE__); |
363
|
530
|
|
|
|
|
374
|
$checksub = 0; |
364
|
|
|
|
|
|
|
} |
365
|
1191
|
|
|
|
|
847
|
push @node_stack, \$node->[$bit]; |
366
|
1191
|
|
|
|
|
812
|
$node = $node->[$bit]; |
367
|
|
|
|
|
|
|
} |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
$checksub |
370
|
47
|
100
|
100
|
|
|
115
|
and defined $node->[$bit] |
|
|
|
100
|
|
|
|
|
371
|
|
|
|
|
|
|
and __PACKAGE__ eq ref $node->[$bit] |
372
|
|
|
|
|
|
|
and _add_check_subtree($node->[$bit], $val); |
373
|
|
|
|
|
|
|
|
374
|
47
|
|
|
|
|
46
|
$node->[$bit] = $val; |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
# Take care of potential mergers into the previous node (if $node[0] == $node[1]) |
377
|
|
|
|
|
|
|
not @node_stack |
378
|
47
|
0
|
33
|
|
|
82
|
and defined $node->[$bit ^ 1] |
|
|
|
33
|
|
|
|
|
379
|
|
|
|
|
|
|
and $node->[$bit ^ 1] eq $val |
380
|
|
|
|
|
|
|
and croak 'merging two /1 blocks is not supported yet'; |
381
|
47
|
|
|
|
|
32
|
while(1) { |
382
|
51
|
|
|
|
|
37
|
$node = pop @node_stack; |
383
|
|
|
|
|
|
|
last unless( |
384
|
51
|
100
|
66
|
|
|
321
|
defined $node |
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
385
|
|
|
|
|
|
|
and defined $$node->[0] |
386
|
|
|
|
|
|
|
and defined $$node->[1] |
387
|
|
|
|
|
|
|
and $$node->[0] eq $$node->[1] |
388
|
|
|
|
|
|
|
); |
389
|
4
|
|
|
|
|
8
|
$$node = $val; |
390
|
|
|
|
|
|
|
} |
391
|
|
|
|
|
|
|
} |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
# Check an existing subtree for incompatible values. Returns false and sets the |
394
|
|
|
|
|
|
|
# package-global error string if there was a problem. |
395
|
|
|
|
|
|
|
sub _add_check_subtree { |
396
|
2
|
|
|
2
|
|
3
|
my ($root, $val) = @_; |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
eval { |
399
|
|
|
|
|
|
|
$root->_walk(0, 0, sub { |
400
|
2
|
|
|
2
|
|
2
|
my $oldval = $_[2]; |
401
|
2
|
50
|
|
|
|
8
|
$val == $oldval or die $oldval; ## no critic (ErrorHandling::RequireCarping) |
402
|
|
|
|
|
|
|
} |
403
|
2
|
|
|
|
|
7
|
); |
404
|
2
|
|
|
|
|
8
|
1; |
405
|
2
|
50
|
|
|
|
3
|
} or do { |
406
|
0
|
0
|
|
|
|
0
|
$@ and croak "incompatible entry, found `$@' trying to add `$val'"; |
407
|
|
|
|
|
|
|
}; |
408
|
2
|
|
|
|
|
2
|
return 1; |
409
|
|
|
|
|
|
|
} |
410
|
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
sub _lookup { |
412
|
11
|
|
|
11
|
|
32
|
my ($node, $addr) = @_; |
413
|
11
|
|
|
|
|
8
|
my $bit; |
414
|
|
|
|
|
|
|
|
415
|
11
|
|
|
|
|
7
|
while(1) { |
416
|
202
|
|
|
|
|
121
|
$bit = ($addr & 0x80000000) >> 31; |
417
|
202
|
100
|
|
|
|
227
|
defined $node->[$bit] or return; |
418
|
199
|
100
|
|
|
|
240
|
__PACKAGE__ ne ref $node->[$bit] and return $node->[$bit]; |
419
|
191
|
|
|
|
|
113
|
$node = $node->[$bit]; |
420
|
191
|
|
|
|
|
109
|
$addr <<= 1; |
421
|
|
|
|
|
|
|
} |
422
|
|
|
|
|
|
|
} |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
# IPv4 address from integer to dotted-quad |
425
|
30
|
|
|
30
|
|
171
|
sub _int2dq { inet_ntop(AF_INET, pack 'N', shift) } |
426
|
|
|
|
|
|
|
|
427
|
|
|
|
|
|
|
# Convert a CIDR block ($addr, $bits) into a range of addresses ($lo, $hi) |
428
|
|
|
|
|
|
|
# sub _cidr2rng { ( $_[0], $_[0] | ((1 << $_[1]) - 1) ) } |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
# Walk the tree in depth-first LTR order |
431
|
|
|
|
|
|
|
sub _walk { |
432
|
13
|
|
|
13
|
|
15
|
my ($node, $addr, $bits, $cb) = @_; |
433
|
13
|
|
|
|
|
8
|
my ($l, $r); |
434
|
13
|
|
|
|
|
22
|
my @node_stack = ($node, $addr, $bits); |
435
|
|
|
|
|
|
|
#print "================== WALK ==================: ", join(':',caller),"\n"; |
436
|
13
|
|
|
|
|
22
|
while(@node_stack) { |
437
|
343
|
|
|
|
|
344
|
($node, $addr, $bits) = splice @node_stack, -3; # pop 3 elems |
438
|
|
|
|
|
|
|
#print "LOOP: stack size ".(@node_stack/3)."\n"; |
439
|
343
|
100
|
|
|
|
407
|
if(__PACKAGE__ eq ref $node) { |
440
|
328
|
|
|
|
|
313
|
($l, $r) = @$node; |
441
|
|
|
|
|
|
|
#printf "Popped [%s, %s]:%s/%d\n", |
442
|
|
|
|
|
|
|
# ($l//'') =~ /^Net::CIDR::Lookup=/ ? '' : $l//'', |
443
|
|
|
|
|
|
|
# ($r//'') =~ /^Net::CIDR::Lookup=/ ? '' : $r//'', |
444
|
|
|
|
|
|
|
# _int2dq($addr), $bits; |
445
|
328
|
|
|
|
|
217
|
++$bits; |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
# Check left side |
448
|
|
|
|
|
|
|
#$addr &= ~(1 << 31-$bits); |
449
|
328
|
100
|
|
|
|
335
|
if(__PACKAGE__ eq ref $l) { |
450
|
|
|
|
|
|
|
#defined $r and print "L: pushing right node=$r, bits=$bits\n"; |
451
|
236
|
100
|
|
|
|
300
|
defined $r and push @node_stack, ($r, $addr | 1 << 32-$bits, $bits); |
452
|
|
|
|
|
|
|
#print "L: pushing left node=$l, bits=$bits\n"; |
453
|
236
|
|
|
|
|
221
|
push @node_stack, ($l, $addr, $bits); |
454
|
|
|
|
|
|
|
#printf "L: addr=%032b (%s)\n", $addr, _int2dq($addr); |
455
|
236
|
|
|
|
|
307
|
next; # Short-circuit back to loop w/o checking $r! |
456
|
|
|
|
|
|
|
} else { |
457
|
|
|
|
|
|
|
#defined $l and printf "L: CALLBACK (%s/%d) => %s\n", _int2dq($addr), $bits, $l; |
458
|
92
|
100
|
|
|
|
138
|
defined $l and $cb->($addr, $bits, $l); |
459
|
|
|
|
|
|
|
} |
460
|
|
|
|
|
|
|
} else { |
461
|
|
|
|
|
|
|
# There was a right-side leaf node on the stack that will end up in |
462
|
|
|
|
|
|
|
# the "else" branch below |
463
|
|
|
|
|
|
|
#print "Found leftover right leaf $node\n"; |
464
|
15
|
|
|
|
|
18
|
$r = $node; |
465
|
|
|
|
|
|
|
} |
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
# Check right side |
468
|
107
|
|
|
|
|
83
|
$addr |= 1 << 32-$bits; |
469
|
107
|
100
|
|
|
|
121
|
if(__PACKAGE__ eq ref $r) { |
470
|
|
|
|
|
|
|
#print "R: pushing right node=$r, bits=$bits\n"; |
471
|
75
|
|
|
|
|
122
|
push @node_stack, ($r, $addr, $bits); |
472
|
|
|
|
|
|
|
#printf "R: addr=%032b (%s)\n", $addr, _int2dq($addr); |
473
|
|
|
|
|
|
|
} else { |
474
|
|
|
|
|
|
|
#defined $r and printf "R: CALLBACK (%s/%d) => %s\n", _int2dq($addr), $bits, $r; |
475
|
32
|
100
|
|
|
|
77
|
defined $r and $cb->($addr, $bits, $r); |
476
|
|
|
|
|
|
|
} |
477
|
|
|
|
|
|
|
} |
478
|
|
|
|
|
|
|
} |
479
|
|
|
|
|
|
|
|
480
|
|
|
|
|
|
|
# Split a chunk into a minimal number of CIDR blocks. |
481
|
|
|
|
|
|
|
sub _do_chunk { |
482
|
38
|
|
|
38
|
|
24
|
my ($chunks, $start, $end, $ix1, $ix2) = @_; |
483
|
38
|
|
|
|
|
23
|
my ($prefix, $xor); |
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
# Find common prefix. After that, the bit indicated by $ix1 is 0 for $start |
486
|
|
|
|
|
|
|
# and 1 for $end. A split a this point guarantees the longest suffix. |
487
|
38
|
|
|
|
|
23
|
$xor = $start ^ $end; |
488
|
38
|
|
100
|
|
|
314
|
--$ix1 until($xor & 1 << $ix1 or -1 == $ix1); |
489
|
38
|
|
|
|
|
30
|
$prefix = $start & ~((1 << ($ix1+1)) - 1); |
490
|
|
|
|
|
|
|
|
491
|
38
|
|
100
|
|
|
453
|
$ix2++ while($ix2 <= $ix1 |
|
|
|
100
|
|
|
|
|
492
|
|
|
|
|
|
|
and not ($start & 1 << $ix2) |
493
|
|
|
|
|
|
|
and ($end & 1 << $ix2)); |
494
|
|
|
|
|
|
|
|
495
|
|
|
|
|
|
|
# Split if $fbits and $lbits disagree on the length of the chunk. |
496
|
38
|
100
|
|
|
|
35
|
if ($ix2 <= $ix1) { |
497
|
17
|
|
|
|
|
51
|
_do_chunk($chunks, $start, $prefix | ((1<<$ix1) - 1), $ix1, $ix2); |
498
|
17
|
|
|
|
|
22
|
_do_chunk($chunks, $prefix | (1<<$ix1), $end, $ix1, $ix2); |
499
|
|
|
|
|
|
|
} else { |
500
|
21
|
|
|
|
|
35
|
push @$chunks, [ $prefix, 31-$ix1 ]; |
501
|
|
|
|
|
|
|
} |
502
|
|
|
|
|
|
|
} |
503
|
|
|
|
|
|
|
|
504
|
|
|
|
|
|
|
1; |