File Coverage

blib/lib/Net/Patricia.pm
Criterion Covered Total %
statement 143 188 76.0
branch 45 130 34.6
condition 11 53 20.7
subroutine 34 42 80.9
pod 6 8 75.0
total 239 421 56.7


line stmt bran cond sub pod time code
1             # Net::Patricia - Patricia Trie perl module for fast IP address lookups
2             # Copyright (C) 2000-2005 Dave Plonka
3             # Copyright (C) 2009 Dave Plonka & Philip Prindeville
4             #
5             # This program is free software; you can redistribute it and/or modify
6             # it under the terms of the GNU General Public License as published by
7             # the Free Software Foundation; either version 2 of the License, or
8             # (at your option) any later version.
9             #
10             # This program is distributed in the hope that it will be useful,
11             # but WITHOUT ANY WARRANTY; without even the implied warranty of
12             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13             # GNU General Public License for more details.
14             #
15             # You should have received a copy of the GNU General Public License
16             # along with this program; if not, write to the Free Software
17             # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
18             # MA 02110-1301, USA.
19              
20             # Dave Plonka
21             # Philip Prindeville
22             # Anton Berezin
23              
24             package Net::Patricia;
25              
26 1     1   276231 use strict;
  1         4  
  1         42  
27 1     1   6 use warnings;
  1         2  
  1         50  
28              
29             require 5.008;
30              
31 1     1   885 use version;
  1         2398  
  1         7  
32 1     1   78 use Carp;
  1         3  
  1         87  
33 1     1   5 use vars qw($VERSION @ISA @EXPORT);
  1         2  
  1         60  
34 1     1   1163 use Socket qw(AF_INET AF_INET6);
  1         5347  
  1         339  
35              
36             BEGIN {
37 1     1   12 require Exporter;
38 1         5 require DynaLoader;
39 1         21 @ISA = qw(Exporter DynaLoader);
40 1         775 @EXPORT = qw(AF_INET AF_INET6);
41             }
42              
43             '$Revision: 1.22 $' =~ m/(\d+)\.(\d+)((_\d+)|)/ && ( $VERSION = "$1.$2$3");
44              
45             bootstrap Net::Patricia $VERSION;
46              
47             sub new {
48 2     2 1 993 my ($class, $type) = @_;
49              
50 2   100     17 $type ||= AF_INET;
51              
52 2 100       8 if ($type == AF_INET) {
53 1         21 return bless _new(32), 'Net::Patricia::AF_INET';
54             }
55              
56 1 50       6 if ($type == AF_INET6) {
57 1         12 return bless _new(128), 'Net::Patricia::AF_INET6';
58             }
59              
60 0         0 croak "new: unimplemented type";
61             }
62              
63             ##
64             ## Compat functions
65             ##
66              
67             sub _ip_bits {
68 34     34   54 my ($self, $str) = @_;
69 34         45 my $bits;
70              
71 34 100       112 if (ref ($self) eq 'Net::Patricia::AF_INET6') {
72 3 50       25 $bits = ($str =~ s|/(\d+)$||) ? $1 : 128;
73             } else {
74 31 100       163 $bits = ($str =~ s|/(\d+)$||) ? $1 : 32;
75             }
76 34         274 ($str,$bits);
77             }
78              
79             sub add_string {
80 12 50 33 12 1 5442 croak "add_string: wrong number of args" if (@_ < 2 || @_ > 3);
81 12         61 my ($self,$str,$data) = @_;
82 12 100       290 $data = $str unless @_ > 2;
83 12         49 $self->add($self->_ip_bits($str),$data);
84             }
85              
86             sub match_string {
87 16 50   16 1 6599 croak "match_string: wrong number of args" if (@_ != 2);
88 16         33 my ($self,$str) = @_;
89 16         39 $self->match($self->_ip_bits($str))
90             }
91              
92             sub match_exact_string {
93 2 50   2 1 10 croak "match_exact_string: wrong number of args" if (@_ != 2);
94 2         5 my ($self,$str) = @_;
95 2         6 $self->exact($self->_ip_bits($str))
96             }
97              
98             sub match_exact_integer {
99 6     6 1 1280 shift->exact_integer(@_)
100             }
101              
102             sub remove_string {
103 4 50   4 1 400 croak "remove_string: wrong number of args" if (@_ != 2);
104 4         10 my ($self,$str) = @_;
105 4         12 $self->remove($self->_ip_bits($str))
106             }
107              
108             BEGIN {
109 1     1   3 eval {
110 1         3 my $class = 'Net::CIDR::Lite';
111 1         72 eval "require $class";
112             };
113 1 50       5223 last if (@_);
114              
115             sub add_cidr {
116 1 50   1 0 648 croak "add_cidr: wrong number of args" if (@_ != 3);
117 1         4 my ($self, $range, $data) = @_;
118 1         15 my $cidr = Net::CIDR::Lite->new();
119 1         32 $cidr->add_range($range);
120              
121 1         428 my @list = ();
122 1         9 for ($cidr->list()) {
123 2 50       197 push(@list, $_) if ($self->add_string($_, $data));
124             }
125 1         23 @list;
126             }
127              
128             sub remove_cidr {
129 1 50   1 0 794 croak "remove_cidr: wrong number of args" if (@_ != 2);
130 1         5 my ($self, $range) = @_;
131 1         9 my $cidr = Net::CIDR::Lite->new();
132 1         21 $cidr->add_range($range);
133              
134 1         206 my @list = ();
135 1         8 for ($cidr->list()) {
136 2 50       225 push(@list, $_) if ($self->remove_string($_));
137             }
138 1         12 @list;
139             }
140             }
141              
142             ##
143             ## AF_INET
144             ##
145              
146             package Net::Patricia::AF_INET;
147              
148 1     1   10 use Carp;
  1         3  
  1         54  
149 1     1   5 use Socket qw(AF_INET inet_aton inet_ntoa);
  1         2  
  1         45  
150 1     1   6 use vars qw(@ISA @EXPORT);
  1         2  
  1         77  
151              
152             BEGIN {
153 1     1   7 require Exporter;
154 1         4 require DynaLoader;
155 1         26 @ISA = qw(Exporter DynaLoader Net::Patricia);
156 1         705 @EXPORT = qw(AF_INET);
157             }
158              
159             sub add {
160 11 50 33 11   68 croak "add: wrong number of args" if (@_ < 2 || @_ > 4);
161 11         26 my ($self, $ip, $bits, $data) = @_;
162 11 0       28 $data = (defined $bits ? "$ip/$bits" : $ip) if (@_ < 4);
    50          
163 11         2908 my $packed = inet_aton($ip);
164 11 100       429 croak("invalid key") unless (defined $packed);
165 10 50       23 $bits = 32 if (@_ < 3);
166 10         123 $self->SUPER::_add(AF_INET, $packed, $bits, $data);
167             }
168              
169             sub add_integer {
170 0 0 0 0   0 croak "add_integer: wrong number of args" if (@_ < 2 || @_ > 4);
171 0         0 my ($self, $num, $bits, $data) = @_;
172 0         0 my $packed = pack("N", $num);
173 0         0 my $ip = inet_ntoa($packed);
174 0 0       0 croak("invalid address") unless (defined $ip);
175 0 0       0 $data = (defined $bits ? "$ip/$bits" : $ip) if (@_ < 4);
    0          
176 0 0       0 $bits = 32 if (@_ < 3);
177 0         0 $self->SUPER::_add(AF_INET, $packed, $bits, $data);
178             }
179              
180             sub match_integer {
181 6 50 33 6   749 croak "match_integer: wrong number of args" if (@_ < 2 || @_ > 3);
182 6         11 my ($self, $num, $bits) = @_;
183 6 50       17 $bits = 32 if (@_ < 3);
184 6         63 $self->SUPER::_match(AF_INET, pack("N",$num), $bits);
185             }
186              
187             sub exact_integer {
188 6 50 33 6   37 croak "exact_integer: wrong number of args" if (@_ < 2 || @_ > 3);
189 6         12 my ($self, $num, $bits) = @_;
190 6 100       15 $bits = 32 if (@_ < 3);
191 6         70 $self->SUPER::_exact(AF_INET, pack("N",$num), $bits);
192             }
193              
194             sub match {
195 14 50 33 14   86 croak "match: wrong number of args" if (@_ < 2 || @_ > 3);
196 14         22 my ($self, $ip, $bits) = @_;
197 14         59 my $packed = inet_aton($ip);
198 14 50       39 croak("invalid key") unless (defined $packed);
199 14 50       36 $bits = 32 if (@_ < 3);
200 14         150 $self->SUPER::_match(AF_INET, $packed, $bits);
201             }
202              
203             sub exact {
204 2 50 33 2   13 croak "exact: wrong number of args" if (@_ < 2 || @_ > 3);
205 2         4 my ($self, $ip, $bits) = @_;
206 2         9 my $packed = inet_aton($ip);
207 2 50       6 croak("invalid key") unless (defined $packed);
208 2 50       5 $bits = 32 if (@_ < 3);
209 2         22 $self->SUPER::_exact(AF_INET, $packed, $bits);
210             }
211              
212             sub remove {
213 4 50 33 4   32 croak "remove: wrong number of args" if (@_ < 2 || @_ > 3);
214 4         11 my ($self, $ip, $bits) = @_;
215 4         27 my $packed = inet_aton($ip);
216 4 50       15 croak("invalid key") unless (defined $packed);
217 4 50       10 $bits = 32 if (@_ < 3);
218 4         57 $self->SUPER::_remove(AF_INET, $packed, $bits);
219             }
220              
221             sub remove_integer {
222 0 0 0 0   0 croak "remote_integer: wrong number of args" if (@_ < 2 || @_ > 3);
223 0         0 my ($self, $num, $bits) = @_;
224 0 0       0 $bits = 32 if (@_ < 3);
225 0         0 $self->SUPER::_remove(AF_INET, pack("N",$num), $bits);
226             }
227              
228             ##
229             ## AF_INET6
230             ##
231              
232             package Net::Patricia::AF_INET6;
233              
234 1     1   5 use Carp;
  1         2  
  1         55  
235 1     1   5 use Socket qw(AF_INET6);
  1         2  
  1         37  
236 1     1   876 use Socket6 qw(inet_pton inet_ntop);
  1         3202  
  1         214  
237 1     1   8 use vars qw(@ISA @EXPORT);
  1         2  
  1         81  
238              
239             BEGIN {
240 1     1   6 require Exporter;
241 1         5 require DynaLoader;
242 1         21 @ISA = qw(Exporter DynaLoader Net::Patricia);
243 1         882 @EXPORT = qw(AF_INET6);
244             }
245              
246             sub add {
247 1 50 33 1   13 croak "add: wrong number of args" if (@_ < 2 || @_ > 4);
248 1         4 my ($self, $ip, $bits, $data) = @_;
249 1 0       7 $data = (defined $bits ? "$ip/$bits" : $ip) if (@_ < 3);
    50          
250 1         21 my $packed = inet_pton(AF_INET6, $ip);
251 1 50       7 croak("invalid key") unless (defined $packed);
252 1 50       5 $bits = 128 if (@_ < 4);
253 1         25 $self->SUPER::_add(AF_INET6, $packed, $bits, $data);
254             }
255              
256             sub add_integer {
257 0 0 0 0   0 croak "add_integer: wrong number of args" if (@_ < 2 || @_ > 4);
258 0         0 my ($self, $num, $bits, $data) = @_;
259 0         0 my $packed = pack("N", $num);
260 0         0 my $ip = inet_ntop(AF_INET6, $packed);
261 0 0       0 croak("invalid address") unless (defined $ip);
262 0 0       0 $data = (defined $bits ? "$ip/$bits" : $ip) if (@_ < 3);
    0          
263 0 0       0 $bits = 128 if (@_ < 4);
264 0         0 $self->SUPER::_add(AF_INET6, $packed, $bits, $data);
265             }
266              
267             sub match_integer {
268 0 0 0 0   0 croak "match_integer: wrong number of args" if (@_ < 2 || @_ > 3);
269 0         0 my ($self, $num, $bits) = @_;
270 0 0       0 $bits = 128 if (@_ < 3);
271 0         0 $self->SUPER::_match(AF_INET6, pack("N",$num), $bits);
272             }
273              
274             sub exact_integer {
275 0 0 0 0   0 croak "exact_integer: wrong number of args" if (@_ < 2 || @_ > 3);
276 0         0 my ($self, $num, $bits) = @_;
277 0 0       0 $bits = 128 if (@_ < 3);
278 0         0 $self->SUPER::_exact(AF_INET6, pack("N",$num), $bits);
279             }
280              
281             sub match {
282 2 50 33 2   15 croak "match: wrong number of args" if (@_ < 2 || @_ > 3);
283 2         5 my ($self, $ip, $bits) = @_;
284 2         9 my $packed = inet_pton(AF_INET6, $ip);
285 2 50       5 croak("invalid key") unless (defined $packed);
286 2 50       8 $bits = 128 if (@_ < 3);
287 2         23 $self->SUPER::_match(AF_INET6, $packed, $bits);
288             }
289              
290             sub exact {
291 0 0 0 0     croak "exact: wrong number of args" if (@_ < 2 || @_ > 3);
292 0           my ($self, $ip, $bits) = @_;
293 0           my $packed = inet_pton(AF_INET6, $ip);
294 0 0         croak("invalid key") unless (defined $packed);
295 0 0         $bits = 128 if (@_ < 3);
296 0           $self->SUPER::_exact(AF_INET6, $packed, $bits);
297             }
298              
299             sub remove {
300 0 0 0 0     croak "remove: wrong number of args" if (@_ < 2 || @_ > 3);
301 0           my ($self, $ip, $bits) = @_;
302 0           my $packed = inet_pton(AF_INET6, $ip);
303 0 0         croak("invalid key") unless (defined $packed);
304 0 0         $bits = 128 if (@_ < 3);
305 0           $self->SUPER::_remove(AF_INET6, $packed, $bits);
306             }
307              
308             sub remove_integer {
309 0 0 0 0     croak "remote_integer: wrong number of args" if (@_ < 2 || @_ > 3);
310 0           my ($self, $num, $bits) = @_;
311 0 0         $bits = 128 if (@_ < 3);
312 0           $self->SUPER::_remove(AF_INET6, pack("N",$num), $bits);
313             }
314              
315             1;
316             __END__