File Coverage

blib/lib/Geo/IPfree.pm
Criterion Covered Total %
statement 136 148 91.8
branch 49 64 76.5
condition 9 19 47.3
subroutine 15 16 93.7
pod 11 11 100.0
total 220 258 85.2


line stmt bran cond sub pod time code
1             package Geo::IPfree;
2 7     7   269930 use 5.006;
  7         50  
3 7     7   31 use strict;
  7         10  
  7         121  
4 7     7   26 use warnings;
  7         10  
  7         145  
5              
6 7     7   29 use Carp qw();
  7         9  
  7         13370  
7              
8             require Exporter;
9             our @ISA = qw(Exporter);
10              
11             our $VERSION = '1.16'; # VERSION
12              
13             # ABSTRACT: Geo::IPfree - Look up the country of an IPv4 address
14              
15             our @EXPORT = qw(LookUp LoadDB);
16             our @EXPORT_OK = @EXPORT;
17              
18             my $DEFAULT_DB = 'ipscountry.dat';
19             my $cache_expire = 5000;
20             my @baseX = (
21             0 .. 9,
22             'A' .. 'Z',
23             'a' .. 'z',
24             split( m{}, q(.,;'"`<>{}[]=+-~*@#%$&!?) )
25             );
26              
27             my ( %baseX, $base, $THIS, %countrys, $base0, $base1, $base2, $base3, $base4 );
28              
29             {
30             my $c = 0;
31             %baseX = map { $_ => ( $c++ ) } @baseX;
32             $base = @baseX;
33             $base0 = $base**0;
34             $base1 = $base**1;
35             $base2 = $base**2;
36             $base3 = $base**3;
37             $base4 = $base**4;
38              
39             my @data;
40             while () {
41             last if m{^__END__};
42             chomp;
43             push @data, split m{ }, $_, 2;
44             }
45             %countrys = @data;
46             }
47              
48             sub new {
49 3     3 1 235 my ( $class, $db_file ) = @_;
50              
51 3 50 33     30 if ( !defined $_[0] || $_[0] !~ /^[\w:]+$/ ) {
52 0         0 $class = 'Geo::IPfree';
53 0         0 $db_file = $_[0];
54             }
55              
56 3         20 my $this = bless( {}, $class );
57              
58 3 50       9 if ( !defined $db_file ) { $db_file = _find_db_file(); }
  3         9  
59              
60 3         18 $this->LoadDB($db_file);
61              
62 3         23 $this->Clean_Cache();
63 3         9 $this->{cache} = 1;
64              
65 3         13 return $this;
66             }
67              
68             sub get_all_countries {
69 0     0 1 0 return {%countrys}; # copy
70             }
71              
72             sub _find_db_file {
73             my @locations = (
74             qw(/usr/local/share /usr/local/share/GeoIPfree),
75 3     3   9 map { $_, "$_/Geo" } @INC
  33         66  
76             );
77              
78             # lastly, find where this module was loaded, and try that dir
79 3         39 my ($lib) = ( $INC{'Geo/IPfree.pm'} =~ /^(.*?)[\\\/]+[^\\\/]+$/gs );
80 3         7 push @locations, $lib;
81              
82 3         8 for my $file ( map { "$_/$DEFAULT_DB" } @locations ) {
  75         126  
83 18 100       6447 return $file if -e $file;
84             }
85             }
86              
87             sub LoadDB {
88 3     3 1 7 my $this = shift;
89 3         8 my ($db_file) = @_;
90              
91 3 50       45 if ( -d $db_file ) { $db_file .= "/$DEFAULT_DB"; }
  0         0  
92              
93 3 50       76 if ( !-s $db_file ) {
94 0         0 Carp::croak("Can't load database, blank or not there: $db_file");
95             }
96              
97 3         9 my $buffer = '';
98 3 50       117 open( my $handler, '<', $db_file )
99             || Carp::croak("Failed to open database file $db_file for read!");
100 3         14 binmode($handler);
101 3         26 $this->{dbfile} = $db_file;
102              
103 3 50       10 delete $this->{pos} if $this->{pos};
104              
105 3         76 while ( read( $handler, $buffer, 1, length($buffer) ) ) {
106 51060 100       239846 if ( $buffer =~ /##headers##(\d+)##$/s ) {
    100          
107 3         16 my $headers;
108 3         31 read( $handler, $headers, $1 );
109 3         1102 my (%head) = ( $headers =~ /(\d+)=(\d+)/gs );
110 3         526 $this->{pos}{$_} = $head{$_} for keys %head;
111 3         83 $buffer = '';
112             }
113             elsif ( $buffer =~ /##start##$/s ) {
114 3         14 $this->{start} = tell($handler);
115 3         8 last;
116             }
117             }
118              
119 3         9 $this->{searchorder} = [ sort { $a <=> $b } keys %{ $this->{pos} } ];
  5212         4888  
  3         81  
120 3         39 $this->{handler} = $handler;
121             }
122              
123             sub LookUp {
124 18     18 1 17653 my $this;
125              
126 18 100       52 if ( $#_ == 0 ) {
127 6 100       13 if ( !$THIS ) { $THIS = Geo::IPfree->new(); }
  1         6  
128 6         7 $this = $THIS;
129             }
130 12         19 else { $this = shift; }
131              
132 18         34 my ($ip) = @_;
133              
134 18 50       65 $ip =~ s/\.+/\./gs if index( $ip, '..' ) > -1;
135 18 50       51 substr( $ip, 0, 1, '' ) if substr( $ip, 0, 1 ) eq '.';
136 18 50       39 chop $ip if substr( $ip, -1 ) eq '.';
137              
138 18 100       127 if ( $ip !~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/ ) {
139 3         15 $ip = nslookup($ip);
140             }
141              
142 18 100       71 return unless length $ip;
143              
144             ## Since the last class is always from the same country, will try 0 and cache 0:
145 15         27 my $ip_class = $ip;
146 15         70 $ip_class =~ s/\.\d+$/\.0/;
147              
148 15 50 33     87 if ( $this->{cache} && $this->{CACHE}{$ip_class} ) {
149 0         0 return ( @{ $this->{CACHE}{$ip_class} }, $ip_class );
  0         0  
150             }
151              
152 15         37 my $ipnb = ip2nb($ip_class);
153              
154 15         23 my $buf_pos = 0;
155              
156 15         20 foreach my $Key ( @{ $this->{searchorder} } ) {
  15         32  
157 2031 100       2539 if ( $ipnb <= $Key ) { $buf_pos = $this->{pos}{$Key}; last; }
  15         29  
  15         21  
158             }
159              
160 15         27 my ( $buffer, $country, $iprange, $basex2 );
161              
162             ## Will use the DB in the memory:
163 15 100       29 if ( $this->{FASTER} ) {
164 5   100     14 my $base_cache = $this->{'baseX2dec'} ||= {};
165 5         20 while ( $buf_pos < $this->{DB_SIZE} ) {
166 1651 100 33     4897 if ( $ipnb >= ( $base_cache->{ ( $basex2 = substr( $this->{DB}, $buf_pos + 2, 5 ) ) } ||= baseX2dec($basex2) ) ) {
167 5         9 $country = substr( $this->{DB}, $buf_pos, 2 );
168 5         7 last;
169             }
170 1646         2348 $buf_pos += 7;
171             }
172 5   33     10 $country ||= substr( $this->{DB}, $buf_pos - 7, 2 );
173             }
174             ## Will read the DB in the disk:
175             else {
176 10 50       23 seek( $this->{handler}, 0, 0 )
177             if $] < 5.006001; ## Fix bug on Perl 5.6.0
178 10         125 seek( $this->{handler}, $buf_pos + $this->{start}, 0 );
179 10         158 while ( read( $this->{handler}, $buffer, 7 ) ) {
180 3302 100       5096 if ( $ipnb >= baseX2dec( substr( $buffer, 2 ) ) ) {
181 10         14 $country = substr( $buffer, 0, 2 );
182 10         23 last;
183             }
184             }
185             }
186              
187 15 50       32 if ( $this->{cache} ) {
188 15 50       26 if ( $this->{CACHE_COUNT} > $cache_expire ) {
189 0         0 keys %{ $this->{CACHE} };
  0         0  
190 0         0 my ($d_key) = each( %{ $this->{CACHE} } );
  0         0  
191 0         0 delete $this->{CACHE}{$d_key};
192             }
193             else {
194 15         21 $this->{CACHE_COUNT}++;
195             }
196 15         64 $this->{CACHE}{$ip_class} = [ $country, $countrys{$country} ];
197             }
198              
199 15         73 return ( $country, $countrys{$country}, $ip_class );
200             }
201              
202             sub Faster {
203 1     1 1 8 my $this = shift;
204 1         2 my $handler = $this->{handler};
205              
206 1         13 seek( $handler, 0, 0 ); ## Fix bug on Perl 5.6.0
207 1         9 seek( $handler, $this->{start}, 0 );
208              
209 1         2 $this->{DB} = do { local $/; <$handler>; };
  1         6  
  1         1809  
210 1         5 $this->{DB_SIZE} = length( $this->{DB} );
211 1         4 $this->{FASTER} = 1;
212             }
213              
214             sub Clean_Cache {
215 4     4 1 1366 my $this = shift;
216 4         14 $this->{CACHE_COUNT} = 0;
217 4         18 delete $this->{CACHE};
218 4         459 delete $this->{'baseX2dec'};
219 4         10 return 1;
220             }
221              
222             sub nslookup {
223 6     6 1 24 my ( $host, $last_lookup ) = @_;
224 6         1869 require Socket;
225 6   50     1758143 my $iaddr = Socket::inet_aton($host) || '';
226 6         72 my @ip = unpack( 'C4', $iaddr );
227              
228 6 100 66     86 return nslookup( "www.${host}", 1 ) if !@ip && !$last_lookup;
229 3         52 return join( '.', @ip );
230             }
231              
232             sub ip2nb {
233 16     16 1 502 my @ip = split( /\./, $_[0] );
234 16         71 return ( $ip[0] << 24 ) + ( $ip[1] << 16 ) + ( $ip[2] << 8 ) + $ip[3];
235             }
236              
237             sub nb2ip {
238 1     1 1 2 my ($input) = @_;
239 1         1 my @ip;
240              
241 1         3 while ( $input > 1 ) {
242 4         8 my $int = int( $input / 256 );
243 4         7 push @ip, $input - ( $int << 8 );
244 4         5 $input = $int;
245             }
246              
247 1 50       3 push @ip, $input if $input > 0;
248 1         2 push @ip, (0) x ( 4 - @ip );
249              
250 1         5 return join( '.', reverse @ip );
251             }
252              
253             sub dec2baseX {
254 86     86 1 44209 my ($dec) = @_;
255 86         124 my @base;
256              
257 86         182 while ( $dec > 1 ) {
258 84         185 my $int = int( $dec / $base );
259 84         147 push @base, $dec - $int * $base;
260 84         188 $dec = $int;
261             }
262              
263 86 100       135 push @base, $dec if $dec > 0;
264 86         169 push @base, (0) x ( 5 - @base );
265              
266 86         161 return join( '', map { $baseX[$_] } reverse @base );
  430         1143  
267             }
268              
269             sub baseX2dec {
270 5043     5043 1 6870 my $string = reverse $_[0];
271 5043         4978 my $length = length $string;
272             return #
273             (
274             0 + ( $length > 4 ? ( $baseX{ substr( $string, 4, 1 ) } * $base4 ) : 0 ) + #
275             ( $length > 3 ? ( $baseX{ substr( $string, 3, 1 ) } * $base3 ) : 0 ) + #
276             ( $length > 2 ? ( $baseX{ substr( $string, 2, 1 ) } * $base2 ) : 0 ) + #
277             ( $length > 1 ? ( $baseX{ substr( $string, 1, 1 ) } * $base1 ) : 0 ) + #
278 5043 100       20942 ( $length ? ( $baseX{ substr( $string, 0, 1 ) } * $base0 ) : 0 ) #
    100          
    100          
    100          
    50          
279             ); #
280             }
281              
282             1;
283              
284             =pod
285              
286             =encoding UTF-8
287              
288             =head1 NAME
289              
290             Geo::IPfree - Geo::IPfree - Look up the country of an IPv4 address
291              
292             =head1 VERSION
293              
294             version 1.16
295              
296             =head1 AUTHOR
297              
298             Graciliano M. P.
299              
300             =head1 COPYRIGHT AND LICENSE
301              
302             This software is copyright (c) 2022 by Graciliano M. P.
303              
304             This is free software; you can redistribute it and/or modify it under
305             the same terms as the Perl 5 programming language system itself.
306              
307             =cut
308              
309             __DATA__