File Coverage

blib/lib/Net/IP/LPM.pm
Criterion Covered Total %
statement 51 68 75.0
branch 8 14 57.1
condition n/a
subroutine 16 20 80.0
pod 7 10 70.0
total 82 112 73.2


line stmt bran cond sub pod time code
1             package Net::IP::LPM;
2              
3             #use 5.010001;
4 2     2   33929 use strict;
  2         4  
  2         70  
5 2     2   7 use warnings;
  2         2  
  2         42  
6 2     2   7 use Carp;
  2         6  
  2         173  
7              
8             require Exporter;
9             #use AutoLoader;
10              
11 2     2   1112 use Socket qw( AF_INET );
  2         6758  
  2         439  
12 2     2   2450 use Socket6 qw( inet_ntop inet_pton AF_INET6 );
  2         2122  
  2         177  
13 2     2   2621 use Data::Dumper;
  2         17883  
  2         454  
14              
15             #our @ISA = qw(DB_File);
16             our @ISA = qw();
17              
18             # Items to export into callers namespace by default. Note: do not export
19             # names by default without a very good reason. Use EXPORT_OK instead.
20             # Do not simply export all your public functions/methods/constants.
21              
22             # This allows declaration use Net::IP::LPM ':all';
23             # If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
24             # will save memory.
25             our %EXPORT_TAGS = ( 'all' => [ qw(
26            
27             ) ] );
28              
29             our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
30              
31             our @EXPORT = qw(
32            
33             );
34              
35             our $VERSION = '1.06';
36             sub AUTOLOAD {
37             # This AUTOLOAD is used to 'autoload' constants from the constant()
38             # XS function.
39            
40 0     0   0 my $constname;
41 0         0 our $AUTOLOAD;
42 0         0 ($constname = $AUTOLOAD) =~ s/.*:://;
43 0 0       0 croak "&Net::NfDump::constant not defined" if $constname eq 'constant';
44 0         0 my ($error, $val) = constant($constname);
45 0 0       0 if ($error) { croak $error; }
  0         0  
46             {
47 2     2   17 no strict 'refs';
  2         4  
  2         1254  
  0         0  
48             # Fixed between 5.005_53 and 5.005_61
49              
50             #XXX if ($] >= 5.00561) {
51             #XXX *$AUTOLOAD = sub () { $val };
52             #XXX }
53             #XXX else {
54 0     0   0 *$AUTOLOAD = sub { $val };
  0         0  
55             #XXX }
56             }
57 0         0 goto &$AUTOLOAD;
58             }
59              
60             require XSLoader;
61             XSLoader::load('Net::IP::LPM', $VERSION);
62              
63             # Preloaded methods go here.
64              
65             # Autoload methods go after =cut, and are processed by the autosplit program.
66              
67             # Below is stub documentation for your module. You'd better edit it!
68              
69             =head1 NAME
70              
71             Net::IP::LPM - Perl implementation of Longest Prefix Match algorithm
72              
73             =head1 SYNOPSIS
74              
75             use Net::IP::LPM;
76              
77             my $lpm = Net::IP::LPM->new();
78              
79             # add prefixes
80             $lpm->add('0.0.0.0/0', 'default');
81             $lpm->add('::/0', 'defaultv6');
82             $lpm->add('147.229.0.0/16', 'net1');
83             $lpm->add('147.229.3.0/24', 'net2');
84             $lpm->add('147.229.3.10/32', 'host3');
85             $lpm->add('147.229.3.11', 'host4');
86             $lpm->add('2001:67c:1220::/32', 'net16');
87             $lpm->add('2001:67c:1220:f565::/64', 'net26');
88             $lpm->add('2001:67c:1220:f565::1235/128', 'host36');
89             $lpm->add('2001:67c:1220:f565::1236', 'host46');
90              
91              
92             printf $lpm->lookup('147.229.100.100'); # returns net1
93             printf $lpm->lookup('147.229.3.10'); # returns host3
94             printf $lpm->lookup('2001:67c:1220::1');# returns net16
95            
96              
97             =head1 DESCRIPTION
98              
99             The module Net::IP::LPM implements the Longest Prefix Match algorithm
100             to both protocols, IPv4 and IPv6. The module uses Trie algo.
101              
102             =head1 PERFORMANCE
103              
104             The module is able to match ~ 1 mln. lookups
105             per second to a complete Internet BGP table (approx. 500,000 prefixes) using a common
106             hardware (2.4GHz Xeon CPU). For more detail, make a test on the module source
107             to check its performance on your system. Module supports both, IPv4 and IPv6 protocols.
108              
109             =head1 CLASS METHODS
110              
111              
112             =head2 new - Class Constructor
113              
114              
115             $lpm = Net::IP::LPM->new( );
116              
117             Constructs a new Net::IP::LPM object.
118              
119             =cut
120             sub new {
121 4     4 1 1446 my ($class, $dbfile) = @_;
122 4         6 my %h;
123 4         10 my $self = {};
124            
125 4         33 $self->{handle} = lpm_init();
126              
127 4         12 bless $self, $class;
128 4         11 return $self;
129             }
130              
131             # converts IPv4 and IPv6 address into common format
132             sub format_addr {
133 0     0 0 0 my ($addr) = @_;
134              
135 0 0       0 if ((my $addr_bin = inet_pton(AF_INET, $addr))) {
136 0         0 return $addr_bin;
137             } else {
138 0         0 return inet_pton(AF_INET6, $addr);
139             }
140              
141             }
142              
143             =head1 OBJECT METHODS
144              
145             =head2 add - Add Prefix
146              
147             $code = $lpm->add( $prefix, $value );
148              
149             Adds a prefix B<$prefix> into the database with value B<$value>. Returns 1 if
150             the prefix was added successfully. Returns 0 when an error occurs (typically the wrong address formating).
151              
152             =cut
153             sub add {
154 458937     458937 1 2019585 my ($self, $prefix, $value) = @_;
155              
156             # printf "PPP: %s %s %s\n", $self->{handle}, $prefix, $value;
157 458937         294435 my ($prefix_bin, $prefix_len);
158              
159 458937         681941 ($prefix, $prefix_len) = split('/', $prefix);
160              
161 458937 100       978084 if (! ($prefix_bin = inet_pton(AF_INET, $prefix)) ) {
162 11953         187053 $prefix_bin = inet_pton(AF_INET6, $prefix);
163             }
164              
165 458937 100       587759 if (!defined($prefix_len)) {
166 4 100       11 if (length($prefix_bin) == 4) {
167 2         3 $prefix_len = 32;
168             } else {
169 2         3 $prefix_len = 128;
170             }
171             }
172              
173 458937         1076206 return lpm_add_raw($self->{handle}, $prefix_bin, $prefix_len, $value);
174             }
175              
176             # legacy code
177 2     2 0 17 sub rebuild {
178             }
179              
180             =head2 lookup - Lookup Address
181              
182            
183             $value = $lpm->$lookup( $address );
184              
185             Looks up the prefix in the database and returns the value. If the prefix is
186             not found or an error occured, the undef value is returned.
187              
188             Before lookups are performed the database has to be rebuilt by C<$lpm-Erebuild()> operation.
189              
190             =cut
191              
192             sub lookup {
193 9000074     9000074 1 25536470 my ($self, $addr) = @_;
194 9000074         5432246 my $addr_bin;
195              
196 9000074 100       15848743 if (! ($addr_bin = inet_pton(AF_INET, $addr)) ) {
197 35         661 $addr_bin = inet_pton(AF_INET6, $addr);
198             }
199              
200 9000074         19981488 return lpm_lookup_raw($self->{handle}, $addr_bin);
201             # return lpm_lookup($self->{handle}, $addr);
202             }
203              
204             =head2 lookup_raw - Lookup Address in raw format
205              
206            
207             $value = $lpm->lookup_raw( $address );
208              
209             The same case as C<$lpm-Elookup> but it takes $address in raw format (result of the inet_ntop function). It is
210             more effective than C<$lpm-Elookup>, because the conversion from text format is not
211             necessary.
212              
213             =cut
214              
215             sub lookup_raw {
216             # my ($self, $addr_bin) = @_;
217              
218 9000072     9000072 1 26860925 return lpm_lookup_raw($_[0]->{handle}, $_[1]);
219             }
220              
221             # legacy code
222              
223             sub lookup_cache_raw {
224             # my ($self, $addr_bin) = @_;
225              
226 72     72 0 2792 return lpm_lookup_raw($_[0]->{handle}, $_[1]);
227              
228             }
229              
230             =head2 info - Returns information about the built trie
231              
232             $ref = $lpm->info();
233              
234             Returns following items
235              
236             ipv4_nodes_total - total number of allocated nodes in trie
237             ipv4_nodes_value - number of allocated nodes in trie that have stored some value
238             ipv4_trie_bytes - number of bytes allocated for trie nodes (without data)
239             ipv6_ - the same for IPv6
240              
241             =cut
242              
243             sub info {
244 1     1 1 292 my ($self) = @_;
245              
246 1         39843 return lpm_info($self->{handle});
247             }
248              
249             =head2 dump - Return hash array reference containg all stored prefixes in the trie
250            
251             $ref = $lpm->dump();
252              
253             =cut
254              
255             sub dump {
256 1     1 1 679 my ($self) = @_;
257              
258 1         55 return lpm_dump($self->{handle});
259             }
260              
261             =head2 finish - Release all data in object
262              
263            
264             $lpm->finish();
265              
266             =cut
267             sub finish {
268 0     0 1 0 my ($self) = @_;
269              
270 0         0 lpm_finish($self->{handle});
271             }
272              
273             sub DESTROY {
274 4     4   1478 my ($self) = @_;
275              
276 4         81572 lpm_destroy($self->{handle});
277             }
278              
279             =head1 SEE ALSO
280              
281             There are also other implementations of the Longest Prefix Match in Perl. However,
282             most of them have some disadvantages (poor performance, lack of support for IPv6
283             or require a lot of time for initial database building). However, in some cases
284             it might be usefull:
285              
286             L
287              
288             L
289              
290             L
291              
292             L
293              
294             L
295              
296             L
297              
298             =head1 AUTHOR
299              
300             Tomas Podermanski Etpoder@cis.vutbr.czE, Martin Ministr Eleadersmash@email.czE, Brno University of Technology
301              
302             =head1 COPYRIGHT AND LICENSE
303              
304             Copyright (C) 2012, Brno University of Technology
305              
306             This library is a free software; you can redistribute it and/or modify
307             it under the same terms as Perl itself.
308              
309              
310             =cut
311              
312             1;
313             __END__