File Coverage

blib/lib/Geo/IPfree.pm

Criterion	Covered	Total	%
statement	41	153	26.8
branch	3	48	6.2
condition	0	11	0.0
subroutine	9	16	56.2
pod	10	10	100.0
total	63	238	26.4

package Geo::IPfree;
use 5.006;
use strict;
use warnings;

use Memoize;
use Carp qw();

require Exporter;
our @ISA = qw(Exporter);

our $VERSION = '1.151940';

our @EXPORT    = qw(LookUp LoadDB);
our @EXPORT_OK = @EXPORT;

my $DEFAULT_DB   = 'ipscountry.dat';
my $cache_expire = 5000;
my @baseX        = (
    0 .. 9,
    'A' .. 'Z',
    'a' .. 'z',
    split( m{}, q(.,;'"`<>{}[]=+-~*@#%$&!?) )
);

my ( %baseX, $base, $THIS, %countrys );

{
    my $c = 0;
    %baseX = map { $_ => ( $c++ ) } @baseX;
    $base = @baseX;

    my @data;
    while (  ) {
        last if m{^__END__};
        chomp;
        push @data, split m{ }, $_, 2;
    }
    %countrys = @data;
}

sub new {
    my ( $class, $db_file ) = @_;

    if ( !defined $_[ 0 ] || $_[ 0 ] !~ /^[\w:]+$/ ) {
        $class   = 'Geo::IPfree';
        $db_file = $_[ 0 ];
    }

    my $this = bless( {}, $class );

    if ( !defined $db_file ) { $db_file = _find_db_file(); }

    $this->LoadDB( $db_file );

    $this->Clean_Cache();
    $this->{ cache } = 1;

    return $this;
}

sub _find_db_file {
    my @locations = (
        qw(/usr/local/share /usr/local/share/GeoIPfree),
        map { $_, "$_/Geo" } @INC
    );

    # lastly, find where this module was loaded, and try that dir
    my ( $lib ) = ( $INC{ 'Geo/IPfree.pm' } =~ /^(.*?)[\\\/]+[^\\\/]+$/gs );
    push @locations, $lib;

    for my $file ( map { "$_/$DEFAULT_DB" } @locations ) {
        return $file if -e $file;
    }
}

sub LoadDB {
    my $this = shift;
    my ( $db_file ) = @_;

    if ( -d $db_file ) { $db_file .= "/$DEFAULT_DB"; }

    if ( !-s $db_file ) {
        Carp::croak( "Can't load database, blank or not there: $db_file" );
    }

    my $buffer = '';
    open( my $handler, '<', $db_file )
        || Carp::croak( "Failed to open database file $db_file for read!" );
    binmode( $handler );
    $this->{ dbfile } = $db_file;

    delete $this->{ pos } if $this->{ pos };

    while ( read( $handler, $buffer, 1, length( $buffer ) ) ) {
        if ( $buffer =~ /##headers##(\d+)##$/s ) {
            my $headers;
            read( $handler, $headers, $1 );
            my ( %head ) = ( $headers =~ /(\d+)=(\d+)/gs );
            $this->{ pos }{ $_ } = $head{ $_ } for keys %head;
            $buffer = '';
        }
        elsif ( $buffer =~ /##start##$/s ) {
            $this->{ start } = tell( $handler );
            last;
        }
    }

    $this->{ searchorder } = [ sort { $a <=> $b } keys %{ $this->{ pos } } ];
    $this->{ handler } = $handler;
}

sub LookUp {
    my $this;

    if ( $#_ == 0 ) {
        if ( !$THIS ) { $THIS = Geo::IPfree->new(); }
        $this = $THIS;
    }
    else { $this = shift; }

    my ( $ip ) = @_;

    $ip =~ s/\.+/\./gs;
    $ip =~ s/^\.//;
    $ip =~ s/\.$//;

    if ( $ip !~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/ ) {
        $ip = nslookup( $ip );
    }

    return unless length $ip;

    ## Since the last class is always from the same country, will try 0 and cache 0:
    my $ip_class = $ip;
    $ip_class =~ s/\.\d+$/\.0/;

    if ( $this->{ cache } && $this->{ CACHE }{ $ip_class } ) {
        return ( @{ $this->{ CACHE }{ $ip_class } }, $ip_class );
    }

    my $ipnb = ip2nb( $ip_class );

    my $buf_pos = 0;

    foreach my $Key ( @{ $this->{ searchorder } } ) {
        if ( $ipnb <= $Key ) { $buf_pos = $this->{ pos }{ $Key }; last; }
    }

    my ( $buffer, $country, $iprange );

    ## Will use the DB in the memory:
    if ( $this->{ FASTER } ) {
        while ( $buf_pos < $this->{ DB_SIZE } ) {
            $buffer  = substr( $this->{ DB }, $buf_pos, 7 );
            $country = substr( $buffer,       0,        2 );
            $iprange = baseX2dec( substr( $buffer, 2, 5 ) );
            $buf_pos += 7;
            last if $ipnb >= $iprange;
        }
    }
    ## Will read the DB in the disk:
    else {
        seek( $this->{ handler }, 0, 0 )
            if $] < 5.006001;    ## Fix bug on Perl 5.6.0
        seek( $this->{ handler }, $buf_pos + $this->{ start }, 0 );
        while ( read( $this->{ handler }, $buffer, 7 ) ) {
            $country = substr( $buffer, 0, 2 );
            $iprange = baseX2dec( substr( $buffer, 2 ) );
            last if $ipnb >= $iprange;
        }
    }

    if ( $this->{ cache } ) {
        if( $this->{ CACHE_COUNT } > $cache_expire ) {
            keys %{ $this->{ CACHE } };
            my( $d_key ) = each( %{ $this->{ CACHE } } );
            delete $this->{ CACHE }{ $d_key };
        }
        else {
            $this->{ CACHE_COUNT }++;
        }
        $this->{ CACHE }{ $ip_class } = [ $country, $countrys{ $country } ];
    }

    return ( $country, $countrys{ $country }, $ip_class );
}

sub Faster {
    my $this = shift;
    my $handler = $this->{ handler };

    seek( $handler, 0, 0 );                 ## Fix bug on Perl 5.6.0
    seek( $handler, $this->{ start }, 0 );

    $this->{ DB } = do { local $/; <$handler>; };
    $this->{ DB_SIZE } = length( $this->{ DB } );

    memoize( 'dec2baseX' );
    memoize( 'baseX2dec' );

    $this->{ FASTER } = 1;
}

sub Clean_Cache {
    my $this = shift;
    $this->{ CACHE_COUNT } = 0;
    delete $this->{ CACHE };
    return 1;
}

sub nslookup {
    my ( $host, $last_lookup ) = @_;
    require Socket;
    my $iaddr = Socket::inet_aton( $host ) || '';
    my @ip = unpack( 'C4', $iaddr );

    return nslookup( "www.${host}", 1 ) if !@ip && !$last_lookup;
    return join( '.', @ip );
}

sub ip2nb {
    my @ip = split( /\./, $_[ 0 ] );
    return ( $ip[ 0 ] << 24 ) + ( $ip[ 1 ] << 16 ) + ( $ip[ 2 ] << 8 )
        + $ip[ 3 ];
}

sub nb2ip {
    my ( $input ) = @_;
    my @ip;

    while ( $input > 1 ) {
        my $int = int( $input / 256 );
        push @ip, $input - ( $int << 8 );
        $input = $int;
    }

    push @ip, $input if $input > 0;
    push @ip, ( 0 ) x ( 4 - @ip );

    return join( '.', reverse @ip );
}

sub dec2baseX {
    my ( $dec ) = @_;
    my @base;

    while ( $dec > 1 ) {
        my $int = int( $dec / $base );
        push @base, $dec - $int * $base;
        $dec = $int;
    }

    push @base, $dec if $dec > 0;
    push @base, ( 0 ) x ( 5 - @base );

    return join( '', map { $baseX[ $_ ] } reverse @base );
}

sub baseX2dec {
    my ( $input ) = @_;

    my @digits = reverse split( '', $input );
    my $dec = 0;

    foreach ( 0 .. @digits - 1 ) {
        $dec += $baseX{ $digits[ $_ ] } * ( $base**$_ );
    }

    return $dec;
}

1;

__DATA__