File Coverage

blib/lib/IP/Location.pm

Criterion	Covered	Total	%
statement	18	132	13.6
branch	0	30	0.0
condition	0	6	0.0
subroutine	6	13	46.1
pod	6	7	85.7
total	30	188	15.9

package IP::Location;

use 5.006000;
use strict;
use warnings;
use FileHandle;
use Encode;
use Encode::CNMap;
require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use IP::Location ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(

) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(

);

our $VERSION = '0.01';

sub new {
    my ($class, @args) = @_;
    my $self = {
                    'CHAR_SET'        => 'GBK',
                    'IP_ENTRY_NUM'    => undef,
                    'VERSION'         => undef,
                    'QQWRY'           => undef,
                    'FIRST_INDEX_OFFSET' => undef,
                    'LAST_INDEX_OFFSET'  => undef,
    };

    bless($self, $class);

    $self->init(@args) if @args;

    return $self;
}

sub init {
    my ($self, $datafile, $char_set) = @_;
    my ($First_Index_Offset, $Last_Index_Offset);
    $self->{'QQWRY'} = FileHandle->new("< $datafile");
    binmode($self->{'QQWRY'});
    sysread($self->{'QQWRY'}, $First_Index_Offset, 4);
    sysread($self->{'QQWRY'}, $Last_Index_Offset, 4);

    $First_Index_Offset = unpack("L", $First_Index_Offset);
    $Last_Index_Offset  = unpack("L", $Last_Index_Offset);

    $self->{FIRST_INDEX_OFFSET} = $First_Index_Offset;
    $self->{LAST_INDEX_OFFSET} = $Last_Index_Offset;
    $self->{IP_ENTRY_NUM} = ($Last_Index_Offset - $First_Index_Offset) / 7 + 1;

    $self->char_set($char_set) if $char_set;
}

sub locate {
    my ($self, $IP_Target) = @_;
    my ($IP_Entry_Cursor1, $IP_Entry_Cursor2, $IP_Entry_Cursor3);
    my $IP_Entry_Data;
    my $IP_Seek_Cursor;
    my $QQWRY = $self->{'QQWRY'};
    my $IP_Seek_Cursor_Tmp;
    my $Redirct_Flags;
    my ($IP_Target_Country, $IP_Target_Area, $IP_Target_Location);
    my @IP_Target = split(/\./, $IP_Target);

    $IP_Target = $IP_Target[0] * 16777216 + $IP_Target[1] * 65536 + $IP_Target[2] * 256 + $IP_Target[3];

    $IP_Entry_Cursor1 = 0;
    $IP_Entry_Cursor3 = $self->{IP_ENTRY_NUM};

    WHILE:
    $IP_Entry_Cursor2 = int(($IP_Entry_Cursor1 + $IP_Entry_Cursor3)/2);

    seek($self->{'QQWRY'}, $self->{FIRST_INDEX_OFFSET} + $IP_Entry_Cursor2 * 7, 0);
    read($self->{'QQWRY'}, $IP_Entry_Data, 4);

    $IP_Entry_Data = unpack("L", $IP_Entry_Data);
    if ($IP_Target < $IP_Entry_Data) {
        $IP_Entry_Cursor3 = $IP_Entry_Cursor2;
        goto WHILE;
    }

    read($self->{'QQWRY'}, $IP_Seek_Cursor, 3);
    $IP_Seek_Cursor = unpack("L", $IP_Seek_Cursor."\0");
    seek($self->{'QQWRY'}, $IP_Seek_Cursor, 0);
    read($self->{'QQWRY'}, $IP_Entry_Data, 4);
    $IP_Entry_Data = unpack("L", $IP_Entry_Data);

    if ($IP_Entry_Data < $IP_Target) {
        if ($IP_Entry_Cursor1 == $IP_Entry_Cursor2) {
        goto LAST;}
        $IP_Entry_Cursor1 = $IP_Entry_Cursor2;
        goto WHILE;
    }

    $/ = "\0";

    read($self->{'QQWRY'}, $Redirct_Flags, 1);

    if ($Redirct_Flags eq "\1") {
        read($self->{'QQWRY'}, $IP_Seek_Cursor, 3);
        $IP_Seek_Cursor = unpack("L", $IP_Seek_Cursor."\0");

        seek($self->{'QQWRY'}, $IP_Seek_Cursor, 0);
        read($self->{'QQWRY'}, $Redirct_Flags, 1);
        if ($Redirct_Flags eq "\2") {
            $IP_Seek_Cursor_Tmp = $IP_Seek_Cursor;
            read($self->{'QQWRY'}, $IP_Seek_Cursor, 3);
            $IP_Seek_Cursor = unpack("L", $IP_Seek_Cursor."\0");
            seek($self->{'QQWRY'}, $IP_Seek_Cursor, 0);
            $IP_Target_Country=<$QQWRY>;
            seek($self->{'QQWRY'}, $IP_Seek_Cursor_Tmp + 4, 0);
            read($self->{'QQWRY'}, $Redirct_Flags, 1);

            if ($Redirct_Flags eq "\2") {
                read($self->{'QQWRY'}, $IP_Seek_Cursor, 3);
                $IP_Seek_Cursor = unpack("L", $IP_Seek_Cursor."\0");
                seek($self->{'QQWRY'}, $IP_Seek_Cursor, 0);
                $IP_Target_Area=<$QQWRY>;
            }
            else {

                $IP_Target_Area=<$QQWRY>;
            }
        }
        else {
            seek($self->{'QQWRY'}, -1, 1);
            $IP_Target_Country=<$QQWRY>;
            read($self->{'QQWRY'}, $Redirct_Flags, 1);
            if ($Redirct_Flags eq "\2") {
                read($self->{'QQWRY'}, $IP_Seek_Cursor, 3);
                $IP_Seek_Cursor = unpack("L", $IP_Seek_Cursor."\0");
                seek($self->{'QQWRY'}, $IP_Seek_Cursor, 0);
            }
            $IP_Target_Area=<$QQWRY>;
        }
    }
    elsif ($Redirct_Flags eq "\2") {
        $IP_Seek_Cursor_Tmp = ($IP_Seek_Cursor + 8);
        read($self->{'QQWRY'}, $IP_Seek_Cursor, 3);
        $IP_Seek_Cursor = unpack("L", $IP_Seek_Cursor."\0");
        seek($self->{'QQWRY'}, $IP_Seek_Cursor, 0);
        $IP_Target_Country=<$QQWRY>;
        seek($self->{'QQWRY'}, $IP_Seek_Cursor_Tmp, 0);
        $IP_Target_Area=<$QQWRY>;
    }
    else {
        seek($self->{'QQWRY'}, -1, 1);
        $IP_Target_Country=<$QQWRY>;

        read($self->{'QQWRY'}, $Redirct_Flags, 1);
        if ($Redirct_Flags eq "\2") {
            read($self->{'QQWRY'}, $IP_Seek_Cursor, 3);
            $IP_Seek_Cursor = unpack("L", $IP_Seek_Cursor."\0");
            seek($self->{'QQWRY'}, $IP_Seek_Cursor, 0);
        }
        else {
            seek($self->{'QQWRY'}, -1, 1);
        }
        $IP_Target_Area = <$QQWRY>;
    }

    LAST:

    chomp($IP_Target_Country, $IP_Target_Area);
    $/ = "\n";

    $IP_Target_Area =~ s/CZ88\.NET//gi;
    $IP_Target_Location = "$IP_Target_Country $IP_Target_Area";
    $IP_Target_Location =~ s/^\s*(.*)\s*$/$1/g;
    $IP_Target_Location = "未知区域" if ($IP_Target_Location =~ m/未知|http/i || $IP_Target_Location eq "");

    return $self->conv($IP_Target_Location);
}

sub conv {
    my ($self, $string) = @_;

    return simp_to_utf8($string) if $self->{'CHAR_SET'} eq 'UTF-8';
    return $string;
}

sub char_set {
    my ($self, $Char_Set) = @_;

    if ($Char_Set) {
        if ($Char_Set ne 'GBK' && $Char_Set ne 'UTF-8') {
            print "Error : CHAR_SET should be either \'GBK\' or \'UTF-8\'!";
            return;
        }

        $self->{CHAR_SET} = $Char_Set;
        return $self->conv($self->{CHAR_SET});
    }
    else {
        return $self->conv($self->{CHAR_SET});
    }
}

sub version {
    my $self = shift;

    return $self->locate("255.255.255.0");
}

sub info {
    my $self = shift;

    my $info1 = "QQWRY version        : ";
    my $info2 = "\n"
            . "Total Entries        : "
            . $self->{'IP_ENTRY_NUM'}
            . "\n"
            . "IP::Location version : $VERSION\n";

    return $self->conv($info1)
        . $self->locate("255.255.255.0")
        . $self->conv($info2);
}
# Preloaded methods go here.

1;
__END__