Geo-IP-RU-IpGeoBase-0.01/0000755000076500007650000000000011304360700013020 5ustar ruzruzGeo-IP-RU-IpGeoBase-0.01/bin/0000755000076500007650000000000011304360700013570 5ustar ruzruzGeo-IP-RU-IpGeoBase-0.01/bin/ip-geo-base-ru0000755000076500007650000001503411304114040016227 0ustar ruzruz#!/usr/bin/env perl use 5.008; use strict; use warnings; use Getopt::Long; my %db = ( dsn => '', user => '', pass => '', table => 'ip_geo_base_ru', ); my %url = ( main => 'http://ipgeobase.ru/files/db/Main/db_files.tar.gz', coordinates => 'http://ipgeobase.ru/files/db/Map_db/block_coord.tar.gz', ); my %opt = ( help => 0, create => 0, coordinates => 1, verbose => 0, ); GetOptions( 'h|help!' => \$opt{'help'}, 'v|verbose!' => \$opt{'verbose'}, 'd|dsn=s' => \$db{'dsn'}, 'u|user=s' => \$db{'user'}, 'p|password=s' => \$db{'pass'}, 't|table=s' => \$db{'table'}, 'source=s' => \$url{'main'}, 'coordinates-source=s' => \$url{'coordinates'}, 'create!' => \$opt{'create'}, 'coordinates!' => \$opt{'coordinates'}, ); if ( !$db{'dsn'} || $opt{'help'} ) { require Pod::Usage; Pod::Usage::pod2usage( -message => "", -exitval => $opt{'help'}? 0 : 1, -verbose => 99, -sections => $opt{'help'}? 'NAME|USAGE|DESCRIPTION|OPTIONS' : 'NAME|USAGE', ); } =head1 NAME ip-geo-base-ru - retrieve DBs from ipgeobase.ru and import them into DB =head1 USAGE ip-geo-base-ru -h ip-geo-base-ru --dsn 'dbi:SQLite:/path/to/my.db' --create ip-geo-base-ru --dsn 'dbi:SQLite:/path/to/my.db' ip-geo-base-ru [-d,--dsn ] [-u,--user ] [-p,--password ] [-t,--table ] [--create] [--source ] [--coordinates-source] [--nocoordinates] =head1 DESCRIPTION Script fetches information about IP blocks and its locations from http://ipgeobase.ru and imports data into a database table. =head1 OPTIONS =over 4 =item * -h, --help - show help and exit =item * -d, --dsn - the only mandatory option - data base connection string. Syntax described in L, example 'dbi:mysql:mydb'. =item * -u, --user, -p, --password - credentials that should be used to connect to the DB. Default values are empty. =item * -t, --table - name of the table in the database where data should be stored, default value is 'ip_geo_base_ru'. =item * --create - use this to create table in the DB for the first time. =item * --source, --coordinates-source - URLs of the files on the site. =item * --nocoordinates - don't import/update coordinates in the DB. Coordinates are in separate file, so it takes a while to update them. Columns are created in any case, so you can change this option any time you like. =back =cut require File::Spec; require Geo::IP::RU::IpGeoBase; my $api = Geo::IP::RU::IpGeoBase->new( db => \%db, ); if ( $opt{'create'} ) { print "Going to create a table\n" if $opt{'verbose'}; $api->create_table; } my ($master, $slave, $coord) = fetch(); my $table = $api->db_info->{'quoted_table'}; $api->dbh->do("UPDATE $table SET in_update = 1"); process_master($master); process_master($slave); process_coordinates($coord) if $coord; $api->dbh->do("DELETE FROM $table WHERE in_update = 1"); sub process_master { my $file = shift; print "Going to process '$file'" if $opt{'verbose'}; open my $fh, '<:encoding(cp1251)', $file or die "Couldn't open $file"; while ( my $str = <$fh> ) { chomp $str; my %rec; @rec{qw(istart iend block country city region federal_district status)} = split /\t/, $str; delete $rec{'country'}; my $res = update( \%rec ); } close $fh; } sub process_coordinates { my $file = shift; print "Going to process '$file'" if $opt{'verbose'}; open my $fh, '<:encoding(cp1251)', $file or die "Couldn't open $file"; while ( my $str = <$fh> ) { chomp $str; my %rec; @rec{qw(block istart iend city region federal_district latitude longitude)} = split /\t/, $str; my (@tmp) = delete @rec{qw(block city region federal_district)}; $api->update_record( %rec, in_update => 0 ); } close $fh; } sub update { my $rec = shift; @{$rec}{'start', 'end'} = split_block( delete $rec->{'block'} ) if $rec->{'block'}; if ( $opt{'create'} ) { print "Inserting block $rec->{start} - $rec->{end}\n" if $opt{'verbose'}; return $api->insert_record( %$rec, in_update => 0 ); } elsif ( $api->fetch_record( $rec->{'istart'}, $rec->{'iend'} ) ) { print "Updating block $rec->{start} - $rec->{end}\n" if $opt{'verbose'}; return $api->update_record( %$rec, in_update => 0 ); } else { print "Inserting block $rec->{start} - $rec->{end}\n" if $opt{'verbose'}; return $api->insert_record( %$rec, in_update => 0 ); } } sub split_block { return split /\s*-\s*/, $_[0], 2; } exit 0; sub fetch { my @files = extract( fetch_file( $url{'main'} ) ); unless ( grep $_ eq 'cidr_ru_master_index.db', @files ) { die "Couldn't find slave DB"; } unless ( grep $_ eq 'cidr_ru_slave_index.db', @files ) { die "Couldn't find slave DB"; } my $master = File::Spec->catfile( tmp_dir(), 'cidr_ru_master_index.db' ); my $slave = File::Spec->catfile( tmp_dir(), 'cidr_ru_slave_index.db' ); return ($master, $slave) unless $opt{'coordinates'}; @files = extract( fetch_file( $url{'coordinates'} ) ); unless ( grep $_ eq 'block_coord.db', @files ) { die "Couldn't find coordinates file"; } my $coord = File::Spec->catfile( tmp_dir(), 'block_coord.db' ); return ($master, $slave, $coord); } sub extract { my $file = shift; print "Going to extract archive '$file'\n" if $opt{'verbose'}; require Archive::Extract; my $ae = Archive::Extract->new( archive => $file ); return $file unless $ae; $ae->extract( to => tmp_dir() ) or die $ae->error; print "Done\n" if $opt{'verbose'}; return @{ $ae->files }; } sub fetch_file { my $url = shift; my ($file) = ($url =~ m{/([^/]+)$}); die "couldn't figure file name from $url" unless $file; my $path = File::Spec->catfile( tmp_dir(), $file ); print "Going to fetch '$url'\n" if $opt{'verbose'}; require LWP::Simple; my $status = LWP::Simple::getstore($url, $path); die "Couldn't get '$url': $status" unless $status == 200; print "Fetched to '$path'\n" if $opt{'verbose'}; return $path; } my $tmp_dir; sub tmp_dir { return $tmp_dir if $tmp_dir; require File::Temp; $tmp_dir = File::Temp->newdir( CLEANUP => 1 ); print "Temporary directory is '$tmp_dir'\n" if $opt{'verbose'}; return $tmp_dir; } Geo-IP-RU-IpGeoBase-0.01/Changes0000644000076500007650000000014011304360560014312 0ustar ruzruz0.01 2009-11-29 * initial release for review * API may change in next several releases Geo-IP-RU-IpGeoBase-0.01/inc/0000755000076500007650000000000011304360700013571 5ustar ruzruzGeo-IP-RU-IpGeoBase-0.01/inc/Module/0000755000076500007650000000000011304360700015016 5ustar ruzruzGeo-IP-RU-IpGeoBase-0.01/inc/Module/Install/0000755000076500007650000000000011304360700016424 5ustar ruzruzGeo-IP-RU-IpGeoBase-0.01/inc/Module/Install/Base.pm0000644000076500007650000000176611304360604017651 0ustar ruzruz#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '0.91'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { $_[0]->admin->VERSION; } sub DESTROY {} package Module::Install::Base::FakeAdmin; my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 154 Geo-IP-RU-IpGeoBase-0.01/inc/Module/Install/Can.pm0000644000076500007650000000333311304360605017471 0ustar ruzruz#line 1 package Module::Install::Can; use strict; use Config (); use File::Spec (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 156 Geo-IP-RU-IpGeoBase-0.01/inc/Module/Install/Fetch.pm0000644000076500007650000000462711304360605020030 0ustar ruzruz#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Geo-IP-RU-IpGeoBase-0.01/inc/Module/Install/Makefile.pm0000644000076500007650000001600311304360605020503 0ustar ruzruz#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing, always use defaults if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } sub makemaker_args { my $self = shift; my $args = ( $self->{makemaker_args} ||= {} ); %$args = ( %$args, @_ ); return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = sShift; my $name = shift; my $args = $self->makemaker_args; $args->{name} = defined $args->{$name} ? join( ' ', $args->{name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } my %test_dir = (); sub _wanted_t { /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1; } sub tests_recursive { my $self = shift; if ( $self->tests ) { die "tests_recursive will not work if tests are already defined"; } my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } %test_dir = (); require File::Find; File::Find::find( \&_wanted_t, $dir ); $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # MakeMaker can complain about module versions that include # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. $self->build_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{VERSION} = $self->version; $args->{NAME} =~ s/-/::/g; if ( $self->tests ) { $args->{test} = { TESTS => $self->tests }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = $self->author; } if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { $args->{NO_META} = 1; } if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } # Merge both kinds of requires into prereq_pm my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_, ($self->configure_requires, $self->build_requires, $self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # merge both kinds of requires into prereq_pm my $subdirs = ($args->{DIR} ||= []); if ($self->bundles) { foreach my $bundle (@{ $self->bundles }) { my ($file, $dir) = @$bundle; push @$subdirs, $dir if -d $dir; delete $prereq->{$file}; } } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } $args->{INSTALLDIRS} = $self->installdirs; my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if (my $preop = $self->admin->preop($user_preop)) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; my $makefile = do { local $/; }; close MAKEFILE or die $!; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 394 Geo-IP-RU-IpGeoBase-0.01/inc/Module/Install/Metadata.pm0000644000076500007650000003530411304360604020512 0ustar ruzruz#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract author version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords }; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config\n"; return $self; } $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; return 1; } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the reall old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless $self->author; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub perl_version_from { my $self = shift; if ( Module::Install::_read($_[0]) =~ m/ ^ (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; $author =~ s{E}{<}g; $author =~ s{E}{>}g; $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } sub license_from { my $self = shift; if ( Module::Install::_read($_[0]) =~ m/ ( =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b .*? ) (=head\\d.*|=cut.*|) \z /ixms ) { my $license_text = $1; my @phrases = ( 'under the same (?:terms|license) as (?:perl|the perl programming language) itself' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'BSD license' => 'bsd', 1, 'Artistic license' => 'artistic', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s{\s+}{\\s+}g; if ( $license_text =~ /\b$pattern\b/i ) { $self->license($license); return 1; } } } warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } sub _extract_bugtracker { my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than on rt.cpan.org link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Geo-IP-RU-IpGeoBase-0.01/inc/Module/Install/ReadmeFromPod.pm0000644000076500007650000000114411304360604021451 0ustar ruzruz#line 1 package Module::Install::ReadmeFromPod; use strict; use warnings; use base qw(Module::Install::Base); use vars qw($VERSION); $VERSION = '0.06'; sub readme_from { my $self = shift; return unless $Module::Install::AUTHOR; my $file = shift || return; my $clean = shift; require Pod::Text; my $parser = Pod::Text->new(); open README, '> README' or die "$!\n"; $parser->output_fh( *README ); $parser->parse_file( $file ); return 1 unless $clean; $self->postamble(<<"END"); distclean :: license_clean license_clean: \t\$(RM_F) README END return 1; } 'Readme!'; __END__ #line 89 Geo-IP-RU-IpGeoBase-0.01/inc/Module/Install/Scripts.pm0000644000076500007650000000101111304360605020406 0ustar ruzruz#line 1 package Module::Install::Scripts; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub install_script { my $self = shift; my $args = $self->makemaker_args; my $exe = $args->{EXE_FILES} ||= []; foreach ( @_ ) { if ( -f $_ ) { push @$exe, $_; } elsif ( -d 'script' and -f "script/$_" ) { push @$exe, "script/$_"; } else { die("Cannot find script '$_'"); } } } 1; Geo-IP-RU-IpGeoBase-0.01/inc/Module/Install/Win32.pm0000644000076500007650000000340311304360605017670 0ustar ruzruz#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; Geo-IP-RU-IpGeoBase-0.01/inc/Module/Install/WriteAll.pm0000644000076500007650000000222211304360605020507 0ustar ruzruz#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91';; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { $self->makemaker_args( PL_FILES => {} ); } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; Geo-IP-RU-IpGeoBase-0.01/inc/Module/Install.pm0000644000076500007650000002411411304360604016767 0ustar ruzruz#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '0.91'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); use Cwd (); use File::Find (); use File::Path (); use FindBin; sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; unless ( -f $self->{file} ) { require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{"$self->{file}"}; delete $INC{"$self->{path}.pm"}; # Save to the singleton $MAIN = $self; return 1; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = delete $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } sub _read { local *FH; if ( $] >= 5.006 ) { open( FH, '<', $_[0] ) or die "open($_[0]): $!"; } else { open( FH, "< $_[0]" ) or die "open($_[0]): $!"; } my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } sub _write { local *FH; if ( $] >= 5.006 ) { open( FH, '>', $_[0] ) or die "open($_[0]): $!"; } else { open( FH, "> $_[0]" ) or die "open($_[0]): $!"; } foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[0]) <=> _version($_[1]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2009 Adam Kennedy. Geo-IP-RU-IpGeoBase-0.01/lib/0000755000076500007650000000000011304360700013566 5ustar ruzruzGeo-IP-RU-IpGeoBase-0.01/lib/Geo/0000755000076500007650000000000011304360700014300 5ustar ruzruzGeo-IP-RU-IpGeoBase-0.01/lib/Geo/IP/0000755000076500007650000000000011304360700014610 5ustar ruzruzGeo-IP-RU-IpGeoBase-0.01/lib/Geo/IP/RU/0000755000076500007650000000000011304360700015136 5ustar ruzruzGeo-IP-RU-IpGeoBase-0.01/lib/Geo/IP/RU/IpGeoBase.pm0000644000076500007650000002023611304126717017305 0ustar ruzruzuse 5.008; use strict; use warnings; package Geo::IP::RU::IpGeoBase; our $VERSION = '0.01'; =head1 NAME Geo::IP::RU::IpGeoBase - look up location by IP address in Russia =head1 DESCRIPTION This module allows you to look up location in DB provided by http://ipgeobase.ru service. Access to the DB is free. Contains information about city, region, federal district and coordinates. DB provided as plain text files and is not very suitable for look ups without loading all data into memory. Instead it's been decided to import data into a database. Use command line utility to create and update back-end DB. At this moment DB can be created in SQLite, mysql and Pg. If you create table manually then probably module will just work. It's very easy to add support for more back-end DBs. Patches are welcome. =head1 METHODS =head2 new Returns a new object. Takes a hash with options, mostly description of the back-end: Geo::IP::RU::IpGeoBase->new( db => { dbh => $dbh, table => 'my_table', } ); # or Geo::IP::RU::IpGeoBase->new( db => { dsn => 'dbi:mysql:mydb', user => 'root', pass => 'secret', table => 'my_table', } ); =over 4 =item * dbh - connected L handle, or you can use dsn. =item * dsn, user, pass - DSN like described in L, for example 'dbi:SQLite:my.db', user name and his password. =item * table - name of the table with data, default is 'ip_geo_base_ru'. =back =cut sub new { my $proto = shift; my $self = bless { @_ }, ref($proto) || $proto; return $self->init; } sub init { my $self = shift; die "No information about database" unless my $db = $self->{'db'}; unless ( $db->{'dbh'} ) { die "No dsn and no dbh" unless $db->{'dsn'}; require DBI; $db->{'dbh'} = DBI->connect( $db->{'dsn'}, $db->{'user'}, $db->{'pass'}, { RaiseError => 0, PrintError => 0 } ); $db->{'dbh'}->do("SET NAMES 'utf8'"); $db->{'decode'} = 1; } else { $db->{'decode'} = 1 unless exists $db->{'decode'}; } if ( $db->{'decode'} ) { require Encode; $db->{'decoder'} = Encode::find_encoding('UTF-8'); } $db->{'driver'} = $db->{'dbh'}{'Driver'}{'Name'} or die "Couldn't figure out driver name of the DB"; $db->{'table'} ||= 'ip_geo_base_ru'; $db->{'quoted_table'} = $db->{'dbh'}->quote_identifier($db->{'table'}); return $self; } =head2 find_by_ip Takes an IP in 'xxx.xxx.xxx.xxx' format and returns information about blocks that contains this IP. Yep, blocks, not a block. In theory DB may contain intersecting blocks. Each record is a hash reference with the fields matching table columns: istart, iend, start, end, city, region, federal_district, latitude and longitude. =cut sub find_by_ip { my $self = shift; my $ip = shift or die 'No IP provided'; my $int = $self->ip2int($ip); return $self->intersections( $int, $int, order => 'ASC', @_ ); } sub ip2int { return unpack 'N', pack 'C4', split /[.]/, $_[1] } sub intersections { my $self = shift; my ($istart, $iend, %rest) = @_; my $table = $self->db_info->{'quoted_table'}; my $dbh = $self->dbh; my $query = "SELECT * FROM $table WHERE " . $dbh->quote_identifier('istart') .' <= '. $dbh->quote($iend) .' AND '. $dbh->quote_identifier('iend') .' >= '. $dbh->quote($istart); $query .= ' ORDER BY iend - istart '. $rest{'order'} if $rest{'order'}; my $res = $dbh->selectall_arrayref( $query, { Slice => {} } );; die "Couldn't execute '$query': ". $dbh->errstr if !$res && $dbh->errstr; return @{ $self->decode( $res ) }; } sub fetch_record { my $self = shift; my ($istart, $iend) = @_; my $table = $self->db_info->{'quoted_table'}; my $dbh = $self->dbh; my $query = "SELECT * FROM $table WHERE " . $dbh->quote_identifier('istart') .' = '. $dbh->quote($istart) .' AND '. $dbh->quote_identifier('iend') .' = '. $dbh->quote($iend); my $res = $self->dbh->selectrow_hashref( $query ); die "Couldn't execute '$query': ". $dbh->errstr if !$res && $dbh->errstr; return $self->decode( $res ); } sub insert_record { my $self = shift; my %rec = @_; my $table = $self->db_info->{'quoted_table'}; my @keys = keys %rec; my $dbh = $self->dbh; my $query = "INSERT INTO $table(". join( ', ', map $dbh->quote_identifier($_), @keys) .")" ." VALUES (". join( ', ', map $dbh->quote( $rec{$_} ), @keys ) .")"; return $dbh->do( $query ) or die "Couldn't execute '$query': ". $dbh->errstr; } sub update_record { my $self = shift; my %rec = @_; my $table = $self->db_info->{'quoted_table'}; my @keys = grep $_ ne 'istart' && $_ ne 'iend', keys %rec; my $dbh = $self->dbh; my $query = "UPDATE $table SET " . join( ' AND ', map $dbh->quote_identifier($_) .' = '. $dbh->quote($rec{$_}), @keys ) ." WHERE " . join( ' AND ', map $dbh->quote_identifier($_) .' = '. $dbh->quote($rec{$_}), qw(istart iend) ); return $dbh->do( $query ) or die "Couldn't execute '$query': ". $dbh->errstr; } sub delete_record { my $self = shift; my ($istart, $iend) = @_; my $table = $self->db_info->{'quoted_table'}; my $dbh = $self->dbh; my $query = "DELETE FROM $table WHERE " . $dbh->quote_identifier('istart') .' = '. $dbh->quote($istart) .' AND '. $dbh->quote_identifier('iend') .' = '. $dbh->quote($iend); return $dbh->do( $query ) or die "Couldn't execute '$query': ". $dbh->errstr; } sub decode { my $self = shift; my $value = shift; return $value unless $self->{'db'}{'decode'}; return $value unless defined $value; my $decoder = $self->{'db'}{'decoder'}; foreach my $rec ( ref($value) eq 'ARRAY'? (@$value) : ($value) ) { $_ = $decoder->decode($_) foreach grep defined, values %$rec; } return $value; } sub db_info { return $_[0]->{'db'} } sub dbh { return $_[0]->{'db'}{'dbh'} } sub create_table { my $self = shift; my $driver = $self->db_info->{'driver'}; my $call = 'create_'. lc( $driver ) .'_table'; die "Table creation is not supported for $driver" unless $self->can($call); return $self->$call(); } sub create_sqlite_table { my $self = shift; my $table = $self->db_info->{'quoted_table'}; my $query = <dbh->do( $query ) or die "Couldn't execute '$query': ". $self->dbh->errstr; } sub create_mysql_table { my $self = shift; my $table = $self->db_info->{'quoted_table'}; my $query = <dbh->do( $query ) or die "Couldn't execute '$query': ". $self->dbh->errstr; } sub create_pg_table { my $self = shift; my $table = $self->db_info->{'quoted_table'}; my $endq = $self->dbh->quote_identifier('end'); my $query = <dbh->do( $query ) or die "Couldn't execute '$query': ". $self->dbh->errstr; } =head1 AUTHOR Ruslan Zakirov ERuslan.Zakirov@gmail.comE =head1 LICENSE Under the same terms as perl itself. =cut 1; Geo-IP-RU-IpGeoBase-0.01/Makefile.PL0000644000076500007650000000053611303720627015005 0ustar ruzruzuse inc::Module::Install; all_from 'lib/Geo/IP/RU/IpGeoBase.pm'; readme_from 'lib/Geo/IP/RU/IpGeoBase.pm'; requires 'Archive::Extract'; requires 'DBI'; requires 'Encode'; requires 'File::Spec'; requires 'File::Temp'; requires 'Getopt::Long'; requires 'LWP::Simple'; install_script 'bin/ip-geo-base-ru'; WriteAll; Geo-IP-RU-IpGeoBase-0.01/MANIFEST0000644000076500007650000000063511304360646014166 0ustar ruzruzbin/ip-geo-base-ru Changes inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/ReadmeFromPod.pm inc/Module/Install/Scripts.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Geo/IP/RU/IpGeoBase.pm Makefile.PL MANIFEST This list of files META.yml README t/basics.t Geo-IP-RU-IpGeoBase-0.01/META.yml0000644000076500007650000000125211304360605014275 0ustar ruzruz--- abstract: 'look up location by IP address in Russia' author: - 'Ruslan Zakirov >Ruslan.Zakirov@gmail.com<' build_requires: ExtUtils::MakeMaker: 6.42 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 0.91' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 module_name: Geo::IP::RU::IpGeoBase name: Geo-IP-RU-IpGeoBase no_index: directory: - inc - t requires: Archive::Extract: 0 DBI: 0 Encode: 0 File::Spec: 0 File::Temp: 0 Getopt::Long: 0 LWP::Simple: 0 perl: 5.8.0 resources: license: http://dev.perl.org/licenses/ version: 0.01 Geo-IP-RU-IpGeoBase-0.01/README0000644000076500007650000000351411304360605013707 0ustar ruzruzNAME Geo::IP::RU::IpGeoBase - look up location by IP address in Russia DESCRIPTION This module allows you to look up location in DB provided by http://ipgeobase.ru service. Access to the DB is free. Contains information about city, region, federal district and coordinates. DB provided as plain text files and is not very suitable for look ups without loading all data into memory. Instead it's been decided to import data into a database. Use command line utility to create and update back-end DB. At this moment DB can be created in SQLite, mysql and Pg. If you create table manually then probably module will just work. It's very easy to add support for more back-end DBs. Patches are welcome. METHODS new Returns a new object. Takes a hash with options, mostly description of the back-end: Geo::IP::RU::IpGeoBase->new( db => { dbh => $dbh, table => 'my_table', } ); # or Geo::IP::RU::IpGeoBase->new( db => { dsn => 'dbi:mysql:mydb', user => 'root', pass => 'secret', table => 'my_table', } ); * dbh - connected DBI handle, or you can use dsn. * dsn, user, pass - DSN like described in DBI, for example 'dbi:SQLite:my.db', user name and his password. * table - name of the table with data, default is 'ip_geo_base_ru'. find_by_ip Takes an IP in 'xxx.xxx.xxx.xxx' format and returns information about blocks that contains this IP. Yep, blocks, not a block. In theory DB may contain intersecting blocks. Each record is a hash reference with the fields matching table columns: istart, iend, start, end, city, region, federal_district, latitude and longitude. AUTHOR Ruslan Zakirov >Ruslan.Zakirov@gmail.com< LICENSE Under the same terms as perl itself. Geo-IP-RU-IpGeoBase-0.01/t/0000755000076500007650000000000011304360700013263 5ustar ruzruzGeo-IP-RU-IpGeoBase-0.01/t/basics.t0000644000076500007650000000044211303443426014722 0ustar ruzruz#!/ust/bin/env perl use strict; use warnings; use Test::More; require Geo::IP::RU::IpGeoBase; my ($dsn, $user, $pass) = @ENV{ qw(IP_GEO_BASE_TEST IP_GEO_BASE_USER IP_GEO_BASE_PASS) }; if ( $dsn ) { plan tests => 1; } else { plan skip_all => "No DSN for testing"; } ok(1);