File Coverage

blib/lib/Geo/IPfree.pm

Criterion	Covered	Total	%
statement	139	149	93.2
branch	52	66	78.7
condition	11	19	57.8
subroutine	15	16	93.7
pod	11	11	100.0
total	228	261	87.3

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

use Carp qw();

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

our $VERSION = '1.160001';    # VERSION

# ABSTRACT: Geo::IPfree - Look up the country of an IPv4 address

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, $base0, $base1, $base2, $base3, $base4 );

{
    my $c = 0;
    %baseX = map { $_ => ( $c++ ) } @baseX;
    $base  = @baseX;
    $base0 = $base**0;
    $base1 = $base**1;
    $base2 = $base**2;
    $base3 = $base**3;
    $base4 = $base**4;

    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 get_all_countries {
    return {%countrys};    # copy
}

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      if index( $ip, '..' ) > -1;
    substr( $ip, 0, 1, '' ) if substr( $ip, 0, 1 ) eq '.';
    chop $ip                if substr( $ip, -1 ) eq '.';

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

    return unless length $ip;

    ## Cache key uses /25 granularity: .0 for last octet 0-127, .128 for 128-255.
    ## This fixes lookups in split /24 blocks while keeping cache compact.
    my $ip_cache = $ip;
    $ip_cache =~ s/\.(\d+)$/ '.' . ($1 < 128 ? '0' : '128') /e;

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

    my $ipnb = ip2nb($ip);

    my $buf_pos = 0;

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

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

    ## Will use the DB in the memory:
    if ( $this->{FASTER} ) {
        my $base_cache = $this->{'baseX2dec'} ||= {};
        while ( $buf_pos < $this->{DB_SIZE} ) {
            if ( $ipnb >= ( $base_cache->{ ( $basex2 = substr( $this->{DB}, $buf_pos + 2, 5 ) ) } ||= baseX2dec($basex2) ) ) {
                $country = substr( $this->{DB}, $buf_pos, 2 );
                last;
            }
            $buf_pos += 7;
        }
        $country ||= substr( $this->{DB}, $buf_pos - 7, 2 );
    }
    ## 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 ) ) {
            if ( $ipnb >= baseX2dec( substr( $buffer, 2 ) ) ) {
                $country = substr( $buffer, 0, 2 );
                last;
            }
        }
    }

    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_cache} = [ $country, $countrys{$country} ];
    }

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

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} );
    $this->{FASTER}  = 1;
}

sub Clean_Cache {
    my $this = shift;
    $this->{CACHE_COUNT} = 0;
    delete $this->{CACHE};
    delete $this->{'baseX2dec'};
    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 $string = reverse $_[0];
    my $length = length $string;
    return    #
      (
        0 + ( $length > 4 ? ( $baseX{ substr( $string, 4, 1 ) } * $base4 ) : 0 ) +    #
          ( $length > 3 ? ( $baseX{ substr( $string, 3, 1 ) } * $base3 ) : 0 ) +      #
          ( $length > 2 ? ( $baseX{ substr( $string, 2, 1 ) } * $base2 ) : 0 ) +      #
          ( $length > 1 ? ( $baseX{ substr( $string, 1, 1 ) } * $base1 ) : 0 ) +      #
          ( $length     ? ( $baseX{ substr( $string, 0, 1 ) } * $base0 ) : 0 )        #
      );                                                                              #
}

1;

=pod

=encoding UTF-8

=head1 NAME

Geo::IPfree - Geo::IPfree - Look up the country of an IPv4 address

=head1 VERSION

version 1.160001

=head1 AUTHOR

Graciliano M. P.

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2022 by Graciliano M. P.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut

__DATA__