File Coverage

blib/lib/IP/QQWry.pm

Criterion	Covered	Total	%
statement	27	130	20.7
branch	4	42	9.5
condition	1	6	16.6
subroutine	8	19	42.1
pod	6	6	100.0
total	46	203	22.6

package IP::QQWry;

use 5.008;
use warnings;
use strict;
use Carp;
use version; our $VERSION = qv('0.0.20');

my %cache;
my $tmp;            # used for hold temporary data

sub new {
    my ( $class, $db ) = @_;
    my $self = {};
    bless $self, $class;
    if ($db) {
        $self->set_db($db);
    }
    return $self;
}

# set db file of which the name is `QQWry.Dat' most of the time.
sub set_db {
    my ( $self, $db ) = @_;
    if ( $db && -r $db ) {
        open $self->{fh}, '<', $db or croak "how can this happen? $!";
        $self->_init_db;
        return 1;
    }
    carp 'set_db failed';
    return;
}

sub _init_db {
    my $self = shift;
    read $self->{fh}, $tmp, 4;
    $self->{first_index} = unpack 'V', $tmp;
    read $self->{fh}, $tmp, 4;
    $self->{last_index} = unpack 'V', $tmp;
}

# sub query is the the interface for user.
# the parameter is a IPv4 address

sub query {
    my ( $self, $input ) = @_;
    unless ( $self->{fh} ) {
        carp 'database is not provided';
        return;
    }

    my $ip = $self->_convert_input($input);

    if ($ip) {
        $cache{$ip} = [ $self->_result($ip) ] unless $self->cached($ip);
        return wantarray ? @{ $cache{$ip} } : join '', @{ $cache{$ip} };
    }
    return;
}

sub _convert_input {
    my ( $self, $input ) = @_;
    if ( $input =~ /(\d+)\.(\d+)\.(\d+)\.(\d+)/ ) {
        return $1 * 256**3 + $2 * 256**2 + $3 * 256 + $4;
    }
    elsif ( $input =~ /(\d+)/ ) {
        return $1;
    }
    else {
        return;
    }
}

sub cached {
    my ( $self, $input ) = @_;
    my $ip = $self->_convert_input($input);
    return $cache{$ip} ? 1 : 0;
}

sub clear {
    my ( $self, $ip ) = @_;
    if ($ip) {
        undef $cache{$ip};
    }
    else {
        undef %cache;
    }
}

sub db_version {
    return shift->query('255.255.255.0');    # db version info is held there
}

# get the useful infomation which will be returned to user

sub _result {
    my ( $self, $ip ) = @_;
    my $index = $self->_index($ip);
    return unless $index;                    # can't find index

    my ( $base, $ext ) = (q{}) x 2;

    seek $self->{fh}, $index + 4, 0;
    read $self->{fh}, $tmp, 3;

    my $offset = unpack 'V', $tmp . chr 0;
    seek $self->{fh}, $offset + 4, 0;
    read $self->{fh}, $tmp, 1;

    my $mode = ord $tmp;

    if ( $mode == 1 ) {
        $self->_seek;
        $offset = tell $self->{fh};
        read $self->{fh}, $tmp, 1;
        $mode = ord $tmp;
        if ( $mode == 2 ) {
            $self->_seek;
            $base = $self->_str;
            seek $self->{fh}, $offset + 4, 0;
            $ext = $self->_ext;
        }
        else {
            seek $self->{fh}, -1, 1;
            $base = $self->_str;
            $ext  = $self->_ext;
        }
    }
    elsif ( $mode == 2 ) {
        $self->_seek;
        $base = $self->_str;
        seek $self->{fh}, $offset + 8, 0;
        $ext = $self->_ext;
    }
    else {
        seek $self->{fh}, -1, 1;
        $base = $self->_str;
        $ext  = $self->_ext;
    }

    # 'CZ88.NET' means we don't have useful information
    $base = '' if $base =~ /CZ88\.NET/;
    $ext = '' if $ext =~ /CZ88\.NET/;
    return ( $base, $ext );
}

sub _index {
    my ( $self, $ip ) = @_;
    my $low = 0;
    my $up  = ( $self->{last_index} - $self->{first_index} ) / 7;
    my ( $mid, $ip_start, $ip_end );

    # find the index using binary search
    while ( $low <= $up ) {
        $mid = int( ( $low + $up ) / 2 );
        seek $self->{fh}, $self->{first_index} + $mid * 7, 0;
        read $self->{fh}, $tmp, 4;
        $ip_start = unpack 'V', $tmp;

        if ( $ip < $ip_start ) {
            $up = $mid - 1;
        }
        else {
            read $self->{fh}, $tmp, 3;
            $tmp = unpack 'V', $tmp . chr 0;
            seek $self->{fh}, $tmp, 0;
            read $self->{fh}, $tmp, 4;
            $ip_end = unpack 'V', $tmp;

            if ( $ip > $ip_end ) {
                $low = $mid + 1;
            }
            else {
                return $self->{first_index} + $mid * 7;
            }
        }
    }

    return;
}

sub _seek {
    my $self = shift;
    read $self->{fh}, $tmp, 3;
    my $offset = unpack 'V', $tmp . chr 0;
    seek $self->{fh}, $offset, 0;
}

# get string ended by \0

sub _str {
    my $self = shift;
    my $str;

    read $self->{fh}, $tmp, 1;
    while ( ord $tmp > 0 ) {
        $str .= $tmp;
        read $self->{fh}, $tmp, 1;
    }
    return $str;
}

sub _ext {
    my $self = shift;
    read $self->{fh}, $tmp, 1;
    my $mode = ord $tmp;

    if ( $mode == 1 || $mode == 2 ) {
        $self->_seek;
        return $self->_str;
    }
    else {
        return chr($mode) . $self->_str;
    }
}

sub DESTROY {
    my $self = shift;
    close $self->{fh} if $self->{fh};
}

1;

__END__