File Coverage

blib/lib/Geo/IP/PurePerl.pm

Criterion	Covered	Total	%
statement	114	418	27.2
branch	2	118	1.6
condition	0	42	0.0
subroutine	37	66	56.0
pod	17	24	70.8
total	170	668	25.4

package Geo::IP::PurePerl;

use strict;
use FileHandle;
use File::Spec;

BEGIN {
  if ( $] >= 5.008 ) {
    require Encode;
    Encode->import(qw/ decode /);
  }
  else {
    *decode = sub {
      local $_ = $_[1];
      use bytes;
       s/([\x80-\xff])/my $c = ord($1);
           my $p = $c >= 192 ? 1 : 0;
           pack ( 'CC' => 0xc2 + $p , $c & ~0x40 ); /ge;
       return $_;
    };
  }
};


use vars qw( @ISA $VERSION @EXPORT $OPEN_TYPE_PATH );

use constant GEOIP_CHARSET_ISO_8859_1 => 0;
use constant GEOIP_CHARSET_UTF8 => 1;

use constant FULL_RECORD_LENGTH => 50;
use constant GEOIP_COUNTRY_BEGIN => 16776960;
use constant RECORD_LENGTH => 3;
use constant GEOIP_STATE_BEGIN_REV0 => 16700000;
use constant GEOIP_STATE_BEGIN_REV1 => 16000000;
use constant STRUCTURE_INFO_MAX_SIZE => 20;
use constant DATABASE_INFO_MAX_SIZE => 100;
use constant GEOIP_COUNTRY_EDITION => 1;
use constant GEOIP_REGION_EDITION_REV0 => 7;
use constant GEOIP_REGION_EDITION_REV1 => 3;
use constant GEOIP_CITY_EDITION_REV0 => 6;
use constant GEOIP_CITY_EDITION_REV1 => 2;
use constant GEOIP_ORG_EDITION => 5;
use constant GEOIP_ISP_EDITION => 4;
use constant GEOIP_PROXY_EDITION => 8;
use constant GEOIP_ASNUM_EDITION => 9;
use constant GEOIP_NETSPEED_EDITION => 10;
use constant GEOIP_DOMAIN_EDITION => 11;
use constant SEGMENT_RECORD_LENGTH => 3;
use constant STANDARD_RECORD_LENGTH => 3;
use constant ORG_RECORD_LENGTH => 4;
use constant MAX_RECORD_LENGTH => 4;
use constant MAX_ORG_RECORD_LENGTH => 300;
use constant US_OFFSET => 1;
use constant CANADA_OFFSET => 677;
use constant WORLD_OFFSET => 1353;
use constant FIPS_RANGE => 360;

$VERSION = '1.26';

require Exporter;
@ISA = qw(Exporter);

# cheat --- try to load Sys::Mmap
BEGIN {
  eval {
     # wrap into eval again, as workaround for centos / mod_perl issue
     # seems they use $@ without eval somewhere

    eval "require Sys::Mmap"
      ? Sys::Mmap->import
      : do {
        for (qw/ PROT_READ MAP_PRIVATE MAP_SHARED /) {
          no strict 'refs';
          my $unused_stub = $_; # we must use a copy
          *$unused_stub = sub { die 'Sys::Mmap required for mmap support' };
        } # for
      }; # do
    1;
  }; # eval
} # begin


sub GEOIP_STANDARD(){0;}
sub GEOIP_MEMORY_CACHE(){1;}

#sub GEOIP_CHECK_CACHE(){2;}
#sub GEOIP_INDEX_CACHE(){4;}
sub GEOIP_MMAP_CACHE(){8;}

sub GEOIP_UNKNOWN_SPEED(){0;}
sub GEOIP_DIALUP_SPEED(){1;}
sub GEOIP_CABLEDSL_SPEED(){2;}
sub GEOIP_CORPORATE_SPEED(){3;}

@EXPORT = qw( GEOIP_STANDARD GEOIP_MEMORY_CACHE GEOIP_MMAP_CACHE
	      GEOIP_UNKNOWN_SPEED GEOIP_DIALUP_SPEED GEOIP_CABLEDSL_SPEED GEOIP_CORPORATE_SPEED );

my @countries = (
    undef,"AP","EU","AD","AE","AF","AG","AI","AL","AM","CW","AO","AQ","AR",
    "AS","AT","AU","AW","AZ","BA","BB","BD","BE","BF","BG","BH","BI","BJ",
    "BM","BN","BO","BR","BS","BT","BV","BW","BY","BZ","CA","CC","CD","CF",
    "CG","CH","CI","CK","CL","CM","CN","CO","CR","CU","CV","CX","CY","CZ",
    "DE","DJ","DK","DM","DO","DZ","EC","EE","EG","EH","ER","ES","ET","FI",
    "FJ","FK","FM","FO","FR","SX","GA","GB","GD","GE","GF","GH","GI","GL",
    "GM","GN","GP","GQ","GR","GS","GT","GU","GW","GY","HK","HM","HN","HR",
    "HT","HU","ID","IE","IL","IN","IO","IQ","IR","IS","IT","JM","JO","JP",
    "KE","KG","KH","KI","KM","KN","KP","KR","KW","KY","KZ","LA","LB","LC",
    "LI","LK","LR","LS","LT","LU","LV","LY","MA","MC","MD","MG","MH","MK",
    "ML","MM","MN","MO","MP","MQ","MR","MS","MT","MU","MV","MW","MX","MY",
    "MZ","NA","NC","NE","NF","NG","NI","NL","NO","NP","NR","NU","NZ","OM",
    "PA","PE","PF","PG","PH","PK","PL","PM","PN","PR","PS","PT","PW","PY",
    "QA","RE","RO","RU","RW","SA","SB","SC","SD","SE","SG","SH","SI","SJ",
    "SK","SL","SM","SN","SO","SR","ST","SV","SY","SZ","TC","TD","TF","TG",
    "TH","TJ","TK","TM","TN","TO","TL","TR","TT","TV","TW","TZ","UA","UG",
    "UM","US","UY","UZ","VA","VC","VE","VG","VI","VN","VU","WF","WS","YE",
    "YT","RS","ZA","ZM","ME","ZW","A1","A2","O1","AX","GG","IM","JE","BL",
    "MF","BQ");
my @code3s = (
    undef,"AP","EU","AND","ARE","AFG","ATG","AIA","ALB","ARM","CUW","AGO","ATA","ARG",
    "ASM","AUT","AUS","ABW","AZE","BIH","BRB","BGD","BEL","BFA","BGR","BHR","BDI","BEN",
    "BMU","BRN","BOL","BRA","BHS","BTN","BVT","BWA","BLR","BLZ","CAN","CCK","COD","CAF",
    "COG","CHE","CIV","COK","CHL","CMR","CHN","COL","CRI","CUB","CPV","CXR","CYP","CZE",
    "DEU","DJI","DNK","DMA","DOM","DZA","ECU","EST","EGY","ESH","ERI","ESP","ETH","FIN",
    "FJI","FLK","FSM","FRO","FRA","SXM","GAB","GBR","GRD","GEO","GUF","GHA","GIB","GRL",
    "GMB","GIN","GLP","GNQ","GRC","SGS","GTM","GUM","GNB","GUY","HKG","HMD","HND","HRV",
    "HTI","HUN","IDN","IRL","ISR","IND","IOT","IRQ","IRN","ISL","ITA","JAM","JOR","JPN",
    "KEN","KGZ","KHM","KIR","COM","KNA","PRK","KOR","KWT","CYM","KAZ","LAO","LBN","LCA",
    "LIE","LKA","LBR","LSO","LTU","LUX","LVA","LBY","MAR","MCO","MDA","MDG","MHL","MKD",
    "MLI","MMR","MNG","MAC","MNP","MTQ","MRT","MSR","MLT","MUS","MDV","MWI","MEX","MYS",
    "MOZ","NAM","NCL","NER","NFK","NGA","NIC","NLD","NOR","NPL","NRU","NIU","NZL","OMN",
    "PAN","PER","PYF","PNG","PHL","PAK","POL","SPM","PCN","PRI","PSE","PRT","PLW","PRY",
    "QAT","REU","ROU","RUS","RWA","SAU","SLB","SYC","SDN","SWE","SGP","SHN","SVN","SJM",
    "SVK","SLE","SMR","SEN","SOM","SUR","STP","SLV","SYR","SWZ","TCA","TCD","ATF","TGO",
    "THA","TJK","TKL","TKM","TUN","TON","TLS","TUR","TTO","TUV","TWN","TZA","UKR","UGA",
    "UMI","USA","URY","UZB","VAT","VCT","VEN","VGB","VIR","VNM","VUT","WLF","WSM","YEM",
    "MYT","SRB","ZAF","ZMB","MNE","ZWE","A1","A2","O1","ALA","GGY","IMN","JEY","BLM",
    "MAF","BES");
my @names  = (
    undef,"Asia/Pacific Region","Europe","Andorra","United Arab Emirates",
    "Afghanistan","Antigua and Barbuda","Anguilla","Albania","Armenia",
    "Curacao","Angola","Antarctica","Argentina","American Samoa",
    "Austria","Australia","Aruba","Azerbaijan","Bosnia and Herzegovina",
    "Barbados","Bangladesh","Belgium","Burkina Faso","Bulgaria",
    "Bahrain","Burundi","Benin","Bermuda","Brunei Darussalam",
    "Bolivia","Brazil","Bahamas","Bhutan","Bouvet Island",
    "Botswana","Belarus","Belize","Canada","Cocos (Keeling) Islands",
    "Congo, The Democratic Republic of the","Central African Republic","Congo","Switzerland","Cote D'Ivoire",
    "Cook Islands","Chile","Cameroon","China","Colombia",
    "Costa Rica","Cuba","Cape Verde","Christmas Island","Cyprus",
    "Czech Republic","Germany","Djibouti","Denmark","Dominica",
    "Dominican Republic","Algeria","Ecuador","Estonia","Egypt",
    "Western Sahara","Eritrea","Spain","Ethiopia","Finland",
    "Fiji","Falkland Islands (Malvinas)","Micronesia, Federated States of","Faroe Islands","France",
    "Sint Maarten (Dutch part)","Gabon","United Kingdom","Grenada","Georgia",
    "French Guiana","Ghana","Gibraltar","Greenland","Gambia",
    "Guinea","Guadeloupe","Equatorial Guinea","Greece","South Georgia and the South Sandwich Islands",
    "Guatemala","Guam","Guinea-Bissau","Guyana","Hong Kong",
    "Heard Island and McDonald Islands","Honduras","Croatia","Haiti","Hungary",
    "Indonesia","Ireland","Israel","India","British Indian Ocean Territory",
    "Iraq","Iran, Islamic Republic of","Iceland","Italy","Jamaica",
    "Jordan","Japan","Kenya","Kyrgyzstan","Cambodia",
    "Kiribati","Comoros","Saint Kitts and Nevis","Korea, Democratic People's Republic of","Korea, Republic of",
    "Kuwait","Cayman Islands","Kazakhstan","Lao People's Democratic Republic","Lebanon",
    "Saint Lucia","Liechtenstein","Sri Lanka","Liberia","Lesotho",
    "Lithuania","Luxembourg","Latvia","Libya","Morocco",
    "Monaco","Moldova, Republic of","Madagascar","Marshall Islands","Macedonia",
    "Mali","Myanmar","Mongolia","Macau","Northern Mariana Islands",
    "Martinique","Mauritania","Montserrat","Malta","Mauritius",
    "Maldives","Malawi","Mexico","Malaysia","Mozambique",
    "Namibia","New Caledonia","Niger","Norfolk Island","Nigeria",
    "Nicaragua","Netherlands","Norway","Nepal","Nauru",
    "Niue","New Zealand","Oman","Panama","Peru",
    "French Polynesia","Papua New Guinea","Philippines","Pakistan","Poland",
    "Saint Pierre and Miquelon","Pitcairn Islands","Puerto Rico","Palestinian Territory","Portugal",
    "Palau","Paraguay","Qatar","Reunion","Romania",
    "Russian Federation","Rwanda","Saudi Arabia","Solomon Islands","Seychelles",
    "Sudan","Sweden","Singapore","Saint Helena","Slovenia",
    "Svalbard and Jan Mayen","Slovakia","Sierra Leone","San Marino","Senegal",
    "Somalia","Suriname","Sao Tome and Principe","El Salvador","Syrian Arab Republic",
    "Swaziland","Turks and Caicos Islands","Chad","French Southern Territories","Togo",
    "Thailand","Tajikistan","Tokelau","Turkmenistan","Tunisia",
    "Tonga","Timor-Leste","Turkey","Trinidad and Tobago","Tuvalu",
    "Taiwan","Tanzania, United Republic of","Ukraine","Uganda","United States Minor Outlying Islands",
    "United States","Uruguay","Uzbekistan","Holy See (Vatican City State)","Saint Vincent and the Grenadines",
    "Venezuela","Virgin Islands, British","Virgin Islands, U.S.","Vietnam","Vanuatu",
    "Wallis and Futuna","Samoa","Yemen","Mayotte","Serbia",
    "South Africa","Zambia","Montenegro","Zimbabwe","Anonymous Proxy",
    "Satellite Provider","Other","Aland Islands","Guernsey","Isle of Man",
    "Jersey","Saint Barthelemy","Saint Martin","Bonaire, Saint Eustatius and Saba");

# --- unfortunately we do not know the path so we assume the
# default path /usr/local/share/GeoIP
# if thats not true, you can set $Geo::IP::PurePerl::OPEN_TYPE_PATH
#
sub open_type {
  my ( $class, $type, $flags ) = @_;
  my %type_dat_name_mapper = (
    GEOIP_COUNTRY_EDITION()     => 'GeoIP',
    GEOIP_REGION_EDITION_REV0() => 'GeoIPRegion',
    GEOIP_REGION_EDITION_REV1() => 'GeoIPRegion',
    GEOIP_CITY_EDITION_REV0()   => 'GeoIPCity',
    GEOIP_CITY_EDITION_REV1()   => 'GeoIPCity',
    GEOIP_ISP_EDITION()         => 'GeoIPISP',
    GEOIP_ORG_EDITION()         => 'GeoIPOrg',
    GEOIP_PROXY_EDITION()       => 'GeoIPProxy',
    GEOIP_ASNUM_EDITION()       => 'GeoIPASNum',
    GEOIP_NETSPEED_EDITION()    => 'GeoIPNetSpeed',
    GEOIP_DOMAIN_EDITION()      => 'GeoIPDomain',
  );

  # backward compatibility for 2003 databases.
  $type -= 105 if $type >= 106;

  my $name = $type_dat_name_mapper{$type};
  die("Invalid database type $type\n") unless $name;

  my $mkpath = sub { File::Spec->catfile( File::Spec->rootdir, @_ ) };

  my $path =
    defined $Geo::IP::PurePerl::OPEN_TYPE_PATH
    ? $Geo::IP::PurePerl::OPEN_TYPE_PATH
    : do {
    $^O eq 'NetWare'
      ? $mkpath->(qw/ etc GeoIP /)
      : do {
            $^O eq 'MSWin32'
        ? $mkpath->(qw/ GeoIP /)
        : $mkpath->(qw/ usr local share GeoIP /);
      }
    };

  my $filename = File::Spec->catfile( $path, $name . '.dat' );
  return $class->open( $filename, $flags );
}


sub open {
  die "Geo::IP::PurePerl::open() requires a path name"
    unless( @_ > 1 and $_[1] );
  my ($class, $db_file, $flags) = @_;
  my $fh = FileHandle->new;
  my $gi;
  CORE::open $fh, $db_file or die "Error opening $db_file";
  binmode($fh);
  if ( $flags && ( $flags & ( GEOIP_MEMORY_CACHE | GEOIP_MMAP_CACHE ) ) ) {
    my %self;

    if ( $flags & GEOIP_MMAP_CACHE ) {
      die "Sys::Mmap required for MMAP support"
        unless defined $Sys::Mmap::VERSION;
      mmap( $self{buf} = undef, 0, PROT_READ, MAP_PRIVATE, $fh )
        or die "mmap: $!";
    }
    else {
      local $/ = undef;
      $self{buf} = <$fh>;
    }
    $self{fh} = $fh;
    $gi = bless \%self, $class;
  }
  else {
    $gi = bless { fh => $fh }, $class;
  }
  $gi->_setup_segments();
  return $gi;
}

sub new {
  my ($class, $db_file, $flags) = @_;
  # this will be less messy once deprecated new( $path, [$flags] )
  # is no longer supported (that's what open() is for)

  my $def_db_file = '/usr/local/share/GeoIP/GeoIP.dat';
    if ($^O eq 'NetWare') {
    $def_db_file = 'sys:/etc/GeoIP/GeoIP.dat';
  } elsif ($^O eq 'MSWin32') {
    $def_db_file = 'c:/GeoIP/GeoIP.dat';
  }
  if ( !defined $db_file ) {
    # called as new()
    $db_file = $def_db_file;
  } elsif ( $db_file =~ /^\d+$/	) {
    # db_file is GEOIP_MEMORY_CACHE or GEOIP_STANDARD
    # called as new( $flags )
    $flags = $db_file;
    $db_file = $def_db_file;
  } # else called as new( $database_filename, [$flags] );

  $class->open( $db_file, $flags );
}

#this function setups the database segments
sub _setup_segments {
  my ($gi) = @_;
  my $a = 0;
  my $i = 0;
  my $j = 0;
  my $delim;
  my $buf;
  $gi->{_charset} = GEOIP_CHARSET_ISO_8859_1;
  $gi->{"databaseType"} = GEOIP_COUNTRY_EDITION;
  $gi->{"record_length"} = STANDARD_RECORD_LENGTH;

  my $filepos = tell($gi->{fh});
  seek($gi->{fh}, -3, 2);
  for ($i = 0; $i < STRUCTURE_INFO_MAX_SIZE; $i++) {
    read($gi->{fh},$delim,3);

    #find the delim
    if ($delim eq (chr(255).chr(255).chr(255))) {
      read($gi->{fh},$a,1);

      #read the databasetype
      $gi->{"databaseType"} = ord($a);

      # backward compatibility for 2003 databases.
      $gi->{databaseType} -= 105 if $gi->{databaseType} >= 106;

      #chose the database segment for the database type
      #if database Type is GEOIP_REGION_EDITION then use database segment GEOIP_STATE_BEGIN
      if ($gi->{"databaseType"} == GEOIP_REGION_EDITION_REV0) {
        $gi->{"databaseSegments"} = GEOIP_STATE_BEGIN_REV0;
      } elsif ($gi->{"databaseType"} == GEOIP_REGION_EDITION_REV1) {
        $gi->{"databaseSegments"} = GEOIP_STATE_BEGIN_REV1;
      }

      #if database Type is GEOIP_CITY_EDITION, GEOIP_ISP_EDITION or GEOIP_ORG_EDITION then
      #read in the database segment
      elsif (($gi->{"databaseType"} == GEOIP_CITY_EDITION_REV0) ||
        ($gi->{"databaseType"} == GEOIP_CITY_EDITION_REV1) ||
        ($gi->{"databaseType"} == GEOIP_ORG_EDITION) ||
        ($gi->{"databaseType"} == GEOIP_ASNUM_EDITION) ||
        ($gi->{"databaseType"} == GEOIP_DOMAIN_EDITION) ||
        ($gi->{"databaseType"} == GEOIP_ISP_EDITION)) {
        $gi->{"databaseSegments"} = 0;

        #read in the database segment for the database type
        read($gi->{fh},$buf,SEGMENT_RECORD_LENGTH);
        for ($j = 0;$j < SEGMENT_RECORD_LENGTH;$j++) {
          $gi->{"databaseSegments"} += (ord(substr($buf,$j,1)) << ($j * 8));
        }

        #record length is four for ISP databases and ORG databases
        #record length is three for country databases, region database and city databases
        if ($gi->{"databaseType"} == GEOIP_ORG_EDITION ||
	        $gi->{"databaseType"} == GEOIP_ISP_EDITION ||
	        $gi->{"databaseType"} == GEOIP_DOMAIN_EDITION) {
            $gi->{"record_length"} = ORG_RECORD_LENGTH;
        }
      }
      last;
    } else {
      seek($gi->{fh}, -4 , 1);
    }
  }
  #if database Type is GEOIP_COUNTY_EDITION then use database segment GEOIP_COUNTRY_BEGIN
  if ($gi->{"databaseType"} == GEOIP_COUNTRY_EDITION ||
      $gi->{"databaseType"} == GEOIP_NETSPEED_EDITION) {
    $gi->{"databaseSegments"} = GEOIP_COUNTRY_BEGIN;
  }
  seek($gi->{fh},$filepos,0);
  return $gi;
}

sub _seek_country {
  my ($gi, $ipnum) = @_;

  my $fh  = $gi->{fh};
  my $offset = 0;

  my ($x0, $x1);

  my $reclen = $gi->{"record_length"};

  for (my $depth = 31; $depth >= 0; $depth--) {
    unless ( exists $gi->{buf} ) {
      seek $fh, $offset * 2 * $reclen, 0;
      read $fh, $x0, $reclen;
      read $fh, $x1, $reclen;
    } else {

      $x0 = substr($gi->{buf}, $offset * 2 * $reclen, $reclen);
      $x1 = substr($gi->{buf}, $offset * 2 * $reclen + $reclen, $reclen);
    }

    $x0 = unpack("V1", $x0."\0");
    $x1 = unpack("V1", $x1."\0");

    if ($ipnum & (1 << $depth)) {
      if ($x1 >= $gi->{"databaseSegments"}) {
        $gi->{last_netmask} = 32 - $depth;
        return $x1;
      }
      $offset = $x1;
    } else {
      if ($x0 >= $gi->{"databaseSegments"}) {
        $gi->{last_netmask} = 32 - $depth;
	    return $x0;
      }
      $offset = $x0;
    }
  }

  print STDERR "Error Traversing Database for ipnum = $ipnum - Perhaps database is corrupt?";
}
sub charset {
  return $_[0]->{_charset};
}

sub set_charset{
  my ( $gi, $charset ) = @_;
  my $old_charset      = $gi->{_charset};
  $gi->{_charset}      = $charset;

  return $old_charset;
}

#this function returns the country code of ip address
sub country_code_by_addr {
  my ($gi, $ip_address) = @_;
  return unless $ip_address =~ m!^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$!;
  return $countries[$gi->id_by_addr($ip_address)];
}

#this function returns the country code3 of ip address
sub country_code3_by_addr {
  my ($gi, $ip_address) = @_;
  return unless $ip_address =~ m!^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$!;
  return $code3s[$gi->id_by_addr($ip_address)];
}

#this function returns the name of ip address
sub country_name_by_addr {
  my ($gi, $ip_address) = @_;
  return unless $ip_address =~ m!^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$!;
  return $names[$gi->id_by_addr($ip_address)];
}

sub id_by_addr {
  my ($gi, $ip_address) = @_;
  return unless $ip_address =~ m!^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$!;
  return $gi->_seek_country(addr_to_num($ip_address)) - GEOIP_COUNTRY_BEGIN;
}

#this function returns the country code of domain name
sub country_code_by_name {
  my ($gi, $host) = @_;
  my $country_id = $gi->id_by_name($host);
  return $countries[$country_id];
}

#this function returns the country code3 of domain name
sub country_code3_by_name {
  my ($gi, $host) = @_;
  my $country_id = $gi->id_by_name($host);
  return $code3s[$country_id];
}

#this function returns the country name of domain name
sub country_name_by_name {
  my ($gi, $host) = @_;
  my $country_id = $gi->id_by_name($host);
  return $names[$country_id];
}

sub id_by_name {
  my ($gi, $host) = @_;
  my $ip_address;
  if ($host =~ m!^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$!) {
    $ip_address = $host;
  } else {
    $ip_address = join('.',unpack('C4',(gethostbyname($host))[4]));
  }
  return unless $ip_address;
  return $gi->_seek_country(addr_to_num($ip_address)) - GEOIP_COUNTRY_BEGIN;
}

#this function returns the city record as a array
sub get_city_record {
  my ($gi, $host) = @_;
  my $ip_address = $gi->get_ip_address($host);
  return unless $ip_address;
  my $record_buf;
  my $record_buf_pos;
  my $char;
  my $metroarea_combo;
  my $record_country_code = "";
  my $record_country_code3 = "";
  my $record_country_name = "";
  my $record_region = "";
  my $record_city = "";
  my $record_postal_code = "";
  my $record_latitude = "";
  my $record_longitude = "";
  my $record_metro_code = "";
  my $record_area_code = "";
  my $str_length = 0;
  my $i;
  my $j;

  #lookup the city
  my $seek_country = $gi->_seek_country(addr_to_num($ip_address));
  if ($seek_country == $gi->{"databaseSegments"}) {
    return;
  }
  #set the record pointer to location of the city record
  my $record_pointer = $seek_country + (2 * $gi->{"record_length"} - 1) * $gi->{"databaseSegments"};

  unless ( exists $gi->{buf} ) {
    seek( $gi->{"fh"}, $record_pointer, 0 );
    read( $gi->{"fh"}, $record_buf, FULL_RECORD_LENGTH );
    $record_buf_pos = 0;
  }
  else {
	  $record_buf = substr($gi->{buf}, $record_pointer, FULL_RECORD_LENGTH);
    $record_buf_pos = 0;
  }

  #get the country
  $char = ord(substr($record_buf,$record_buf_pos,1));
  $record_country_code = $countries[$char];#get the country code
  $record_country_code3 = $code3s[$char];#get the country code with 3 letters
  $record_country_name = $names[$char];#get the country name
  $record_buf_pos++;

  #get the region
  $char = ord(substr($record_buf,$record_buf_pos+$str_length,1));
  while ($char != 0) {
    $str_length++;#get the length of string
    $char = ord(substr($record_buf,$record_buf_pos+$str_length,1));
  }
  if ($str_length > 0) {
    $record_region = substr($record_buf,$record_buf_pos,$str_length);
  }
  $record_buf_pos += $str_length + 1;
  $str_length = 0;

  #get the city
  $char = ord(substr($record_buf,$record_buf_pos+$str_length,1));
  while ($char != 0) {
    $str_length++;#get the length of string
    $char = ord(substr($record_buf,$record_buf_pos+$str_length,1));
  }
  if ($str_length > 0) {
    $record_city = substr($record_buf,$record_buf_pos,$str_length);
  }
  $record_buf_pos += $str_length + 1;
  $str_length = 0;

  #get the postal code
  $char = ord(substr($record_buf,$record_buf_pos+$str_length,1));
  while ($char != 0) {
    $str_length++;#get the length of string
    $char = ord(substr($record_buf,$record_buf_pos+$str_length,1));
  }
  if ($str_length > 0) {
    $record_postal_code = substr($record_buf,$record_buf_pos,$str_length);
  }
  $record_buf_pos += $str_length + 1;
  $str_length = 0;
  my $latitude = 0;
  my $longitude = 0;

  #get the latitude
  for ($j = 0;$j < 3; ++$j) {
    $char = ord(substr($record_buf,$record_buf_pos++,1));
    $latitude += ($char << ($j * 8));
  }
  $record_latitude = ($latitude/10000) - 180;

  #get the longitude
  for ($j = 0;$j < 3; ++$j) {
    $char = ord(substr($record_buf,$record_buf_pos++,1));
    $longitude += ($char << ($j * 8));
  }
  $record_longitude = ($longitude/10000) - 180;

  #get the metro code and the area code
  if (GEOIP_CITY_EDITION_REV1 == $gi->{"databaseType"}) {
    $metroarea_combo = 0;
    if ($record_country_code eq "US") {
      #if the country is US then read the metro area combo
      for ($j = 0;$j < 3;++$j) {
        $char = ord(substr($record_buf,$record_buf_pos++,1));
        $metroarea_combo += ($char << ($j * 8));
      }
      #split the metro area combo into the metro code and the area code
      $record_metro_code = int($metroarea_combo/1000);
      $record_area_code = $metroarea_combo%1000;
    }
  }

  # the pureperl API must convert the string by themself to UTF8
  # using Encode for perl >= 5.008 otherwise use it's own iso-8859-1 to utf8      converter
   $record_city = decode( 'iso-8859-1' => $record_city )
     if $gi->charset == GEOIP_CHARSET_UTF8;

  return ($record_country_code,$record_country_code3,$record_country_name,$record_region,$record_city,$record_postal_code,$record_latitude,$record_longitude,$record_metro_code,$record_area_code);
}

#this function returns the city record as a hash ref
sub get_city_record_as_hash {
  my ($gi, $host) = @_;
  my %h;
  @h{qw/ country_code country_code3 country_name
         region       city          postal_code
		 latitude     longitude     metro_code
		 area_code                  /}
		 = $gi->get_city_record($host);
  $h{dma_code} = $h{metro_code}; # alias for depreciated dma_code
  return \%h;
}

#this function returns isp or org of the domain name
sub org_by_name {
  my ($gi, $host) = @_;
  my $ip_address = $gi->get_ip_address($host);
  my $seek_org = $gi->_seek_country(addr_to_num($ip_address));
  my $char;
  my $org_buf;
  my $org_buf_length = 0;
  my $record_pointer;

  if ($seek_org == $gi->{"databaseSegments"}) {
    return undef;
  }

  $record_pointer = $seek_org + (2 * $gi->{"record_length"} - 1) * $gi->{"databaseSegments"};

  unless ( exists $gi->{buf} ) {
    seek( $gi->{"fh"}, $record_pointer, 0 );
    read( $gi->{"fh"}, $org_buf, MAX_ORG_RECORD_LENGTH );
  }
  else {
    $org_buf = substr($gi->{buf}, $record_pointer, MAX_ORG_RECORD_LENGTH );
  }

  $char = ord(substr($org_buf,0,1));
  while ($char != 0) {
    $org_buf_length++;
    $char = ord(substr($org_buf,$org_buf_length,1));
  }

  $org_buf = substr($org_buf, 0, $org_buf_length);
  return $org_buf;
}

#this function returns isp or org of the domain name
*isp_by_name = \*org_by_name;

*org_by_addr = \*org_by_name;
*isp_by_addr = \*org_by_name;

#this function returns the region
sub region_by_name {
  my ($gi, $host) = @_;
  my $ip_address = $gi->get_ip_address($host);
  return unless $ip_address;
  if ($gi->{"databaseType"} == GEOIP_REGION_EDITION_REV0) {
    my $seek_region = $gi->_seek_country(addr_to_num($ip_address)) - GEOIP_STATE_BEGIN_REV0;
    if ($seek_region >= 1000) {
      return ("US",chr(($seek_region - 1000)/26 + 65) . chr(($seek_region - 1000)%26 + 65));
    } else {
      return ($countries[$seek_region],"");
    }
  } elsif ($gi->{"databaseType"} == GEOIP_REGION_EDITION_REV1) {
    my $seek_region = $gi->_seek_country(addr_to_num($ip_address)) - GEOIP_STATE_BEGIN_REV1;
    if ($seek_region < US_OFFSET) {
      return ("","");
    } elsif ($seek_region < CANADA_OFFSET) {
      # return a us state
      return ("US",chr(($seek_region - US_OFFSET)/26 + 65) . chr(($seek_region - US_OFFSET)%26 + 65));
    } elsif ($seek_region < WORLD_OFFSET) {
      # return a canada province
      return ("CA",chr(($seek_region - CANADA_OFFSET)/26 + 65) . chr(($seek_region - CANADA_OFFSET)%26 + 65));
    } else {
      # return a country of the world
      my $c = $countries[($seek_region - WORLD_OFFSET) / FIPS_RANGE];
      my $a2 = ($seek_region - WORLD_OFFSET) % FIPS_RANGE;
      my $r = chr(($a2 / 100)+48) . chr((($a2 / 10) % 10)+48) . chr(($a2 % 10)+48);
      return ($c,$r);
    }
  }
}

sub get_ip_address {
  my ($gi, $host) = @_;
  my $ip_address;
  #check if host is ip address
  if ($host =~ m!^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$!) {
    #host is ip address
    $ip_address = $host;
  } else {
    #host is domain name do a dns lookup
    $ip_address = join('.',unpack('C4',(gethostbyname($host))[4]));
  }
  return $ip_address;
}

sub addr_to_num { unpack( N => pack( C4 => split( /\./, $_[0] ) ) ) }
sub num_to_addr { join q{.}, unpack( C4 => pack( N => $_[0] ) ) }

sub database_info {
  my $gi = shift;
  my $i = 0;
  my $buf;
  my $retval;
  my $hasStructureInfo;
  seek($gi->{fh},-3,2);
  for (my $i = 0;$i < STRUCTURE_INFO_MAX_SIZE;$i++) {
    read($gi->{fh},$buf,3);
    if ($buf eq (chr(255) . chr(255) . chr(255))) {
      $hasStructureInfo = 1;
      last;
    }
    seek($gi->{fh},-4,1);
  }
  if ($hasStructureInfo == 1) {
    seek($gi->{fh},-6,1);
  } else {
    # no structure info, must be pre Sep 2002 database, go back to
    seek($gi->{fh},-3,2);
  }
  for (my $i = 0;$i < DATABASE_INFO_MAX_SIZE;$i++){
    read($gi->{fh},$buf,3);
    if ($buf eq (chr(0). chr(0). chr(0))){
      read($gi->{fh},$retval,$i);
      return $retval;
    }
    seek($gi->{fh},-4,1);
  }
  return "";
}

sub range_by_ip {
  my $gi = shift;
  my $ipnum          = addr_to_num( shift );
  my $c              = $gi->_seek_country( $ipnum );
  my $nm             = $gi->last_netmask;
  my $m              = 0xffffffff << 32 - $nm;
  my $left_seek_num  = $ipnum & $m;
  my $right_seek_num = $left_seek_num + ( 0xffffffff & ~$m );

  while ( $left_seek_num != 0
          and $c == $gi->_seek_country(  $left_seek_num - 1) ) {
    my $lm = 0xffffffff << 32 - $gi->last_netmask;
    $left_seek_num = ( $left_seek_num - 1 ) & $lm;
  }
  while ( $right_seek_num != 0xffffffff
          and $c == $gi->_seek_country( $right_seek_num + 1 ) ) {
    my $rm = 0xffffffff << 32 - $gi->last_netmask;
    $right_seek_num = ( $right_seek_num + 1 ) & $rm;
    $right_seek_num += ( 0xffffffff & ~$rm );
  }
  return ( num_to_addr($left_seek_num), num_to_addr($right_seek_num) );
}

sub netmask { $_[0]->{last_netmask} = $_[1] }

sub last_netmask {
  return $_[0]->{last_netmask};
}

sub DESTROY {
  my $gi = shift;

  if ( exists $gi->{buf} && $gi->{flags} && ( $gi->{flags} & GEOIP_MMAP_CACHE ) ) {
    munmap( $gi->{buf} ) or die "munmap: $!";
	  delete $gi->{buf};
  }
}
1;
__END__