Geohash-0.04/000755 000765 000765 00000000000 12037161662 012115 5ustar00koko000000 000000 Geohash-0.04/Changes000644 000765 000765 00000000630 12037161652 013406 0ustar00koko000000 000000 Revision history for Perl extension GeoHash 0.04 2012-10-16T13:33:30+09:00 - fixed to backend detection bug (reported by sugyan++) 0.03 2012-10-05T16:03:12+09:00 - fixed require module name typo (Test::Require) 0.02 2012-10-02T14:22:18+09:00 - rename module name GeoHash to Geohash - add documentation 0.01 2012-09-30T16:05:45+09:00 - original version Geohash-0.04/inc/000755 000765 000765 00000000000 12037161662 012666 5ustar00koko000000 000000 Geohash-0.04/lib/000755 000765 000765 00000000000 12037161662 012663 5ustar00koko000000 000000 Geohash-0.04/Makefile.PL000644 000765 000765 00000000440 12032515060 014053 0ustar00koko000000 000000 use inc::Module::Install; name 'Geohash'; all_from 'lib/Geohash.pm'; readme_from 'lib/Geohash.pm'; readme_markdown_from 'lib/Geohash.pm'; githubmeta; requires 'parent'; requires 'Geo::Hash'; build_requires 'Test::More'; tests 't/*.t'; author_tests 'xt'; auto_set_repository; WriteAll; Geohash-0.04/MANIFEST000644 000765 000765 00000001377 12032475071 013253 0ustar00koko000000 000000 Changes inc/Module/Install.pm inc/Module/Install/AuthorTests.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/GithubMeta.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/ReadmeFromPod.pm inc/Module/Install/ReadmeMarkdownFromPod.pm inc/Module/Install/Repository.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm inc/Pod/Markdown.pm lib/Geohash.pm Makefile.PL MANIFEST This list of files META.yml README README.mkdn t/001_geohash.t t/002_adjacent.t t/003_neighbors.t t/004_decode_to_interval.t t/005_precision.t t/006_merge.t t/007_split.t t/008_validate.t t/00_compile.t xt/01_podspell.t xt/02_perlcritic.t xt/03_pod.t xt/compat-pp.t xt/compat-xs.t xt/perlcriticrc Geohash-0.04/META.yml000644 000765 000765 00000001250 12037161662 013364 0ustar00koko000000 000000 --- abstract: 'Great all in one Geohash library' author: - 'Kazuhiro Osawa ' build_requires: ExtUtils::MakeMaker: 6.36 Test::More: 0 configure_requires: ExtUtils::MakeMaker: 6.36 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.06' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Geohash no_index: directory: - inc - t - xt requires: Geo::Hash: 0 parent: 0 resources: homepage: https://github.com/yappo/p5-Geohash/tree license: http://dev.perl.org/licenses/ repository: git://github.com/yappo/p5-Geohash.git version: 0.04 Geohash-0.04/README000644 000765 000765 00000010734 12037161662 013002 0ustar00koko000000 000000 NAME Geohash - Great all in one Geohash library SYNOPSIS simple wrapper use Geohash; my $gh = Geohash->new(); my $hash = $gh->encode( $lat, $lon ); # default precision = 32 my $hash = $gh->encode( $lat, $lon, $precision ); my ($lat, $lon) = $gh->decode( $hash ); my ($lat_range, $lon_range) = $gh->decode_to_interval( $hash ); my $precision = $gh->precision($lat, $lon); compatible with Pure Perl and XS my $adjacent_hash = $gh->adjacent($hash, $where); my @list_of_geohashes = $gh->neighbors($hash, $around, $offset); specific utilities of Geohash.pm my @list_of_merged_geohashes = $gh->merge(@list_of_geohashes); my @list_of_geohashes = $gh->split(@list_of_merged_geohashes); my $bool = $gh->validate( $geohash ); fource use pp BEGIN { $ENV{PERL_GEOHASH_BACKEND} = 'Geo::Hash' } use Geohash; fource use xs BEGIN { $ENV{PERL_GEOHASH_BACKEND} = 'Geo::Hash::XS' } use Geohash; DESCRIPTION Geohash can handle easily Geohash. Geohash uses Geo::Hash or Geo::Hash::XS as a backend module. You can easy choose of Pure-Perl implement or XS implement. In addition, we have also been added useful utility methods. Why did you not used the name of Geo::Hash::Any? Geohash official name is not *Geo::Hash*. It should not be separated by *::*. And I think of **::Any* namespace is not preferable. I think so no problem with increasing the namespace if a namespace that can be used to implement and intuitive. METHODS $gh = Geohash->new() $hash = $gh->encode($lat, $lon[, $precision]) Encodes the given $lat and $lon to a geohash. If $precision is not given, automatically adjusts the precision according the the given $lat and $lon values. If you do not want Geohash to spend time calculating this, explicitly specify $precision. ($lat, $lon) = $gh->decode( $hash ) Decodes $hash to $lat and $lon ($lat_range, $lon_range) = $gh->decode_to_interval( $hash ) Like "decode()" but "decode_to_interval()" decodes $hash to $lat_range and $lon_range. Each range is a reference to two element arrays which contains the upper and lower bounds. $precision = $gh->precision($lat, $lon) Returns the apparent required precision to describe the given latitude and longitude. $adjacent_hash = $gh->adjacent($hash, $where) Returns the adjacent geohash. $where denotes the direction, so if you want the block to the right of $hash, you say: use Geohash qw(ADJ_RIGHT); my $gh = Geohash->new(); my $adjacent = $gh->adjacent( $hash, ADJ_RIGHT ); @list_of_geohashes = $gh->neighbors($hash, $around, $offset) Returns the list of neighbors (the blocks surrounding $hash) @list_of_merged_geohashes = $gh->merge(@list_of_geohashes) Merged with the larger area from geohash list. And remove duplicated geohash in @list_of_geohashes. my @list = $gh->merge(qw/ c2b25ps0 c2b25ps1 c2b25ps2 c2b25ps3 c2b25ps4 c2b25ps5 c2b25ps6 c2b25ps7 c2b25ps8 c2b25ps9 c2b25psb c2b25psc c2b25psd c2b25pse c2b25psf c2b25psg c2b25psh c2b25psj c2b25psk c2b25psm c2b25psn c2b25psp c2b25psq c2b25psr c2b25pss c2b25pst c2b25psu c2b25psv c2b25psw c2b25psx c2b25psy c2b25psz /); is($list[0], 'c2b25ps'); @list_of_geohashes = $gh->split(@list_of_merged_geohashes) geohash splitter. my @list = $gh->split('c2b25ps'); is_deeply(\@list, [ qw/ c2b25ps0 c2b25ps1 c2b25ps2 c2b25ps3 c2b25ps4 c2b25ps5 c2b25ps6 c2b25ps7 c2b25ps8 c2b25ps9 c2b25psb c2b25psc c2b25psd c2b25pse c2b25psf c2b25psg c2b25psh c2b25psj c2b25psk c2b25psm c2b25psn c2b25psp c2b25psq c2b25psr c2b25pss c2b25pst c2b25psu c2b25psv c2b25psw c2b25psx c2b25psy c2b25psz / ]); $bool = $gh->validate($geohash) Verify correct as geohash. ok($gh->validate('c2b25ps0'); ok(not $gh->validate('a'); # can not use 'a' ok(not $gh->validate(); # required option CONSTANTS ADJ_LEFT, ADJ_RIGHT, ADJ_TOP, ADJ_BOTTOM Used to specify the direction in "adjacent()" AUTHOR Kazuhiro Osawa SEE ALSO Geo::Hash, Geo::Hash::XS, , THANKS TO dirkus, tokuhirom, nipotan LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Geohash-0.04/README.mkdn000644 000765 000765 00000011017 12037161661 013724 0ustar00koko000000 000000 # NAME Geohash - Great all in one Geohash library # SYNOPSIS simple wrapper use Geohash; my $gh = Geohash->new(); my $hash = $gh->encode( $lat, $lon ); # default precision = 32 my $hash = $gh->encode( $lat, $lon, $precision ); my ($lat, $lon) = $gh->decode( $hash ); my ($lat_range, $lon_range) = $gh->decode_to_interval( $hash ); my $precision = $gh->precision($lat, $lon); compatible with Pure Perl and XS my $adjacent_hash = $gh->adjacent($hash, $where); my @list_of_geohashes = $gh->neighbors($hash, $around, $offset); specific utilities of Geohash.pm my @list_of_merged_geohashes = $gh->merge(@list_of_geohashes); my @list_of_geohashes = $gh->split(@list_of_merged_geohashes); my $bool = $gh->validate( $geohash ); fource use pp BEGIN { $ENV{PERL_GEOHASH_BACKEND} = 'Geo::Hash' } use Geohash; fource use xs BEGIN { $ENV{PERL_GEOHASH_BACKEND} = 'Geo::Hash::XS' } use Geohash; # DESCRIPTION [Geohash](http://search.cpan.org/perldoc?Geohash) can handle easily Geohash. Geohash uses [Geo::Hash](http://search.cpan.org/perldoc?Geo::Hash) or [Geo::Hash::XS](http://search.cpan.org/perldoc?Geo::Hash::XS) as a backend module. You can easy choose of Pure-Perl implement or XS implement. In addition, we have also been added useful utility methods. # Why did you not used the name of Geo::Hash::Any? Geohash official name is not _Geo::Hash_. It should not be separated by _::_. And I think of _*::Any_ namespace is not preferable. I think so no problem with increasing the namespace if a namespace that can be used to implement and intuitive. # METHODS ## $gh = Geohash->new() ## $hash = $gh->encode($lat, $lon[, $precision]) Encodes the given `$lat` and `$lon` to a geohash. If `$precision` is not given, automatically adjusts the precision according the the given `$lat` and `$lon` values. If you do not want Geohash to spend time calculating this, explicitly specify `$precision`. ## ($lat, $lon) = $gh->decode( $hash ) Decodes $hash to $lat and $lon ## ($lat_range, $lon_range) = $gh->decode_to_interval( $hash ) Like `decode()` but `decode_to_interval()` decodes $hash to $lat_range and $lon_range. Each range is a reference to two element arrays which contains the upper and lower bounds. ## $precision = $gh->precision($lat, $lon) Returns the apparent required precision to describe the given latitude and longitude. ## $adjacent_hash = $gh->adjacent($hash, $where) Returns the adjacent geohash. `$where` denotes the direction, so if you want the block to the right of `$hash`, you say: use Geohash qw(ADJ_RIGHT); my $gh = Geohash->new(); my $adjacent = $gh->adjacent( $hash, ADJ_RIGHT ); ## @list_of_geohashes = $gh->neighbors($hash, $around, $offset) Returns the list of neighbors (the blocks surrounding $hash) ## @list_of_merged_geohashes = $gh->merge(@list_of_geohashes) Merged with the larger area from geohash list. And remove duplicated geohash in @list_of_geohashes. my @list = $gh->merge(qw/ c2b25ps0 c2b25ps1 c2b25ps2 c2b25ps3 c2b25ps4 c2b25ps5 c2b25ps6 c2b25ps7 c2b25ps8 c2b25ps9 c2b25psb c2b25psc c2b25psd c2b25pse c2b25psf c2b25psg c2b25psh c2b25psj c2b25psk c2b25psm c2b25psn c2b25psp c2b25psq c2b25psr c2b25pss c2b25pst c2b25psu c2b25psv c2b25psw c2b25psx c2b25psy c2b25psz /); is($list[0], 'c2b25ps'); ## @list_of_geohashes = $gh->split(@list_of_merged_geohashes) geohash splitter. my @list = $gh->split('c2b25ps'); is_deeply(\@list, [ qw/ c2b25ps0 c2b25ps1 c2b25ps2 c2b25ps3 c2b25ps4 c2b25ps5 c2b25ps6 c2b25ps7 c2b25ps8 c2b25ps9 c2b25psb c2b25psc c2b25psd c2b25pse c2b25psf c2b25psg c2b25psh c2b25psj c2b25psk c2b25psm c2b25psn c2b25psp c2b25psq c2b25psr c2b25pss c2b25pst c2b25psu c2b25psv c2b25psw c2b25psx c2b25psy c2b25psz / ]); ## $bool = $gh->validate($geohash) Verify correct as geohash. ok($gh->validate('c2b25ps0'); ok(not $gh->validate('a'); # can not use 'a' ok(not $gh->validate(); # required option # CONSTANTS ## ADJ_LEFT, ADJ_RIGHT, ADJ_TOP, ADJ_BOTTOM Used to specify the direction in `adjacent()` # AUTHOR Kazuhiro Osawa # SEE ALSO [Geo::Hash](http://search.cpan.org/perldoc?Geo::Hash), [Geo::Hash::XS](http://search.cpan.org/perldoc?Geo::Hash::XS), [http://en.wikipedia.org/wiki/Geohash](http://en.wikipedia.org/wiki/Geohash), [http://geohash.org/](http://geohash.org/) # THANKS TO dirkus, tokuhirom, nipotan # LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.Geohash-0.04/t/000755 000765 000765 00000000000 12037161662 012360 5ustar00koko000000 000000 Geohash-0.04/xt/000755 000765 000765 00000000000 12037161662 012550 5ustar00koko000000 000000 Geohash-0.04/xt/01_podspell.t000644 000765 000765 00000000411 12032470364 015050 0ustar00koko000000 000000 use Test::More; eval q{ use Test::Spelling }; plan skip_all => "Test::Spelling is not installed." if $@; add_stopwords(map { split /[\s\:\-]/ } ); $ENV{LANG} = 'C'; all_pod_files_spelling_ok('lib'); __DATA__ Kazuhiro Osawa yappo {at} shibuya {dot} pl Geohash Geohash-0.04/xt/02_perlcritic.t000644 000765 000765 00000000333 12022307065 015366 0ustar00koko000000 000000 use strict; use Test::More; eval { require Test::Perl::Critic; Test::Perl::Critic->import( -profile => 'xt/perlcriticrc'); }; plan skip_all => "Test::Perl::Critic is not installed." if $@; all_critic_ok('lib'); Geohash-0.04/xt/03_pod.t000644 000765 000765 00000000201 12022307065 014003 0ustar00koko000000 000000 use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); Geohash-0.04/xt/compat-pp.t000644 000765 000765 00000000256 12022323507 014630 0ustar00koko000000 000000 use strict; use Test::More; use Test::Requires 'Geo::Hash'; $ENV{PERL_GEOHASH_BACKEND} = 'Geo::Hash'; while () { subtest $_ => sub { do $_ }; } done_testing(); Geohash-0.04/xt/compat-xs.t000644 000765 000765 00000000266 12022323547 014650 0ustar00koko000000 000000 use strict; use Test::More; use Test::Requires 'Geo::Hash::XS'; $ENV{PERL_GEOHASH_BACKEND} = 'Geo::Hash::XS'; while () { subtest $_ => sub { do $_ }; } done_testing(); Geohash-0.04/xt/perlcriticrc000644 000765 000765 00000000063 12022307065 015150 0ustar00koko000000 000000 [TestingAndDebugging::ProhibitNoStrict] allow=refs Geohash-0.04/t/001_geohash.t000644 000765 000765 00000003555 12037160273 014550 0ustar00koko000000 000000 use strict; use warnings; use Test::More; use Geohash; my @tests = ( { hash => 'ezs42', pos => [ 42.6, -5.6 ], eps => 0.01, }, { hash => 'mh7w', pos => [ -20, 50 ], eps => 0.1, }, { hash => 't3b9m', pos => [ 10.1, 57.2 ], eps => 0.1, }, { hash => 'c2b25ps', pos => [ 49.26, -123.26 ], eps => 0.01, }, { hash => '80021bgm', pos => [ 0.005, -179.567 ], eps => 0.001, }, { hash => 'k484ht99h2', pos => [ -30.55555, 0.2 ], eps => 0.00001, }, { hash => '8buh2w4pnt', pos => [ 5.00001, -140.6 ], eps => 0.00001, }, ); ok my $gh = Geohash->new, "created new Geohash object"; isa_ok $gh, 'Geohash'; for my $test ( @tests ) { my ( $hash, $pos, $eps ) = @{$test}{qw(hash pos eps)}; is $gh->encode( @$pos, length $hash ), $hash, "$hash: encode"; { my @got = $gh->decode( $hash ); ok abs( $got[$_] - $pos->[$_] ) < $eps, "$hash: decode $_" for 0 .. 1; } { my $enc_hash = $gh->encode( @$pos ); ok abs( length( $enc_hash ) - length( $hash ) ) <= 1, "$hash: auto precision"; # diag "@$pos ($hash) -> $enc_hash"; my @got = $gh->decode( $enc_hash ); ok abs( $got[$_] - $pos->[$_] ) < $eps, "$hash: decode $_" for 0 .. 1; } } my @bad_cases = ( { pos => [ '35.21.03.342', '138.34.45.725' ], }, { pos => [ '112', '138.34.45.725' ], }, { pos => [ '35.21.03.342', '95' ], } ); for my $test ( @bad_cases ) { my ( $pos ) = @{$test}{qw( pos )}; my $ret = eval { $gh->encode( @$pos ); }; if ($gh->backend_class ne 'Geo::Hash::XS') { ok $ret; } else { ok $@; } } done_testing; Geohash-0.04/t/002_adjacent.t000644 000765 000765 00000001601 12032470205 014664 0ustar00koko000000 000000 use strict; use warnings; use Test::More; use Geohash qw(:adjacent); ok my $gh = Geohash->new; isa_ok $gh, 'Geohash'; # Made these tests by using # http://blog.masuidrive.jp/wp-content/uploads/2010/01/geohash.html is $gh->adjacent('xn76gg', ADJ_RIGHT), lc 'xn76u5'; # RIGHT is $gh->adjacent('xn76gg', ADJ_LEFT), lc 'xn76ge'; # LEFT is $gh->adjacent('xn76gg', ADJ_TOP), lc 'xn76gu'; # TOP is $gh->adjacent('xn76gg', ADJ_BOTTOM), lc 'xn76gf'; # BOTTOM is $gh->adjacent('xpst02vt', ADJ_RIGHT), 'xpst02vv'; # RIGHT is $gh->adjacent('xpst02vt', ADJ_LEFT), 'xpst02vm'; # LEFT is $gh->adjacent('xpst02vt', ADJ_TOP), 'xpst02vw'; # TOP is $gh->adjacent('xpst02vt', ADJ_BOTTOM), 'xpst02vs'; # BOTTOM # Check edge cases is $gh->adjacent('00', ADJ_BOTTOM), 'bp'; is $gh->adjacent('00', ADJ_LEFT) , 'pb'; is $gh->adjacent('zz', ADJ_TOP) , 'pb'; is $gh->adjacent('zz', ADJ_RIGHT) , 'bp'; done_testing; Geohash-0.04/t/003_neighbors.t000644 000765 000765 00000002266 12032470216 015106 0ustar00koko000000 000000 use strict; use warnings; use Test::More; use Geohash; ok my $gh = Geohash->new; isa_ok $gh, 'Geohash'; { my @set = $gh->neighbors('xn76gg'); my @expect = qw/xn76gu xn76uh xn76u5 xn76u4 xn76gf xn76gd xn76ge xn76gs/; ok eq_set \@set, \@expect or diag "got '@set', but expected '@expect'"; } { my @set = $gh->neighbors('xpst02vt'); my @expect = qw/xpst02vw xpst02vy xpst02vv xpst02vu xpst02vs xpst02vk xpst02vm xpst02vq/; ok eq_set \@set, \@expect or diag "got '@set', but expected '@expect'"; } { my @set = $gh->neighbors('xn76gg', 2); my @expect = qw/xn76gu xn76uh xn76u5 xn76u4 xn76gf xn76gd xn76ge xn76gs xn76gv xn76gm xn76gk xn76g7 xn76um xn76u6 xn76g3 xn76g9 xn76uk xn76u7 xn76gc xn76uj xn76gt xn76g6 xn76u1 xn76u3/; ok eq_set \@set, \@expect or diag "got '@set', but expected '@expect'"; } { my @set = $gh->neighbors('xn76gg', 1, 1); my @expect = qw/xn76gv xn76gm xn76gk xn76g7 xn76um xn76u6 xn76g3 xn76g9 xn76uk xn76u7 xn76gc xn76uj xn76gt xn76g6 xn76u1 xn76u3/; ok eq_set \@set, \@expect or diag "got '@set', but expected '@expect'"; } done_testing; Geohash-0.04/t/004_decode_to_interval.t000644 000765 000765 00000001024 12032470244 016750 0ustar00koko000000 000000 use strict; use warnings; use Test::More; use Geohash; # The test data are introduced from # http://github.com/masuidrive/pr_geohash/blob/master/test/test_pr_geohash.rb my %tests = ( 'c216ne' => [ [ 45.37353515625, 45.3680419921875 ], [ -121.695556640625, -121.70654296875 ] ], 'dqcw4' => [ [ 39.0673828125, 39.0234375 ], [ -76.5087890625, -76.552734375 ] ], ); my $gh = Geohash->new; for (keys %tests) { is_deeply [$gh->decode_to_interval($_)], $tests{$_}; } done_testing; Geohash-0.04/t/005_precision.t000644 000765 000765 00000000702 12032470273 015117 0ustar00koko000000 000000 use strict; use warnings; use Test::More; use Geohash; my $gh = Geohash->new; is $gh->precision('45', '-120'), 4; is $gh->precision('45.0', '-120'), 5; is $gh->precision('45', '-120.0'), 5; is $gh->precision('45.00', '-120'), 6; is $gh->precision('45', '-120.00'), 6; is $gh->precision('45.000', '-120'), 7; is $gh->precision('45', '-120.000'), 8; is $gh->precision('45.00000', '-120'), 10; is $gh->precision('45', '-120.00000'), 10; done_testing; Geohash-0.04/t/006_merge.t000644 000765 000765 00000005015 12032470303 014220 0ustar00koko000000 000000 use strict; use warnings; use Test::More; use Geohash; my $gh = Geohash->new; subtest 'bad' => sub { my @list = $gh->merge(qw/ a2b c2b25ps0 c2b25ps1 c2b25ps2 c2b25ps3 c2b25ps4 c2b25ps5 c2b25ps6 c2b25ps7 c2b25ps8 c2b25ps9 c2b25psb c2b25psc c2b25psd c2b25pse czc 2b25psf c2b25psg c2b25psh c2b25psj c2b25psk c2b25psm c2b25psy c2b25psz z /); is_deeply(\@list, [qw/ 2b25psf a2b c2b25ps0 c2b25ps1 c2b25ps2 c2b25ps3 c2b25ps4 c2b25ps5 c2b25ps6 c2b25ps7 c2b25ps8 c2b25ps9 c2b25psb c2b25psc c2b25psd c2b25pse c2b25psg c2b25psh c2b25psj c2b25psk c2b25psm c2b25psy c2b25psz czc z /]); }; subtest 'simple ok' => sub { my @list = sort $gh->merge(qw/ a2b c2b25ps0 c2b25ps1 c2b25ps2 c2b25ps3 c2b25ps4 c2b25ps5 c2b25ps6 c2b25ps7 c2b25ps8 c2b25ps9 c2b25psb c2b25psc c2b25psd c2b25pse czc 2b25psf c2b25psf c2b25psg c2b25psh c2b25psj c2b25psk c2b25psm c2b25psn c2b25psp c2b25psq c2b25psr c2b25pss c2b25pst c2b25psu c2b25psv c2b25psw c2b25psx c2b25psy c2b25psz z /); is_deeply(\@list, [qw/ 2b25psf a2b c2b25ps czc z /]); }; subtest 'nest ok' => sub { my @list = sort $gh->merge(qw/ c2b0 c2b1 c2b3 c2b4 c2b5 c2b6 c2b7 c2b8 c2b9 c2bb c2bc c2bd c2be c2bf c2bg c2bh c2bj c2bk c2bm c2bn c2bp c2bq c2br c2bs c2bt c2bu c2bv c2bw c2bx c2by c2bz c2b20 c2b21 c2b22 c2b23 c2b24 c2b26 c2b27 c2b28 c2b29 c2b2b c2b2c c2b2d c2b2e c2b2f c2b2g c2b2h c2b2j c2b2k c2b2m c2b2n c2b2p c2b2q c2b2r c2b2s c2b2t c2b2u c2b2v c2b2w c2b2x c2b2y c2b2z c2b250 c2b251 c2b252 c2b253 c2b254 c2b255 c2b256 c2b257 c2b258 c2b259 c2b25b c2b25c c2b25d c2b25e c2b25f c2b25g c2b25h c2b25j c2b25k c2b25m c2b25n c2b25q c2b25r c2b25s c2b25t c2b25u c2b25v c2b25w c2b25x c2b25y c2b25z c2b25p0 c2b25p1 c2b25p2 c2b25p3 c2b25p4 c2b25p5 c2b25p6 c2b25p7 c2b25p8 c2b25p9 c2b25pb c2b25pc c2b25pd c2b25pe c2b25pf c2b25pg c2b25ph c2b25pj c2b25pk c2b25pm c2b25pn c2b25pp c2b25pq c2b25pr c2b25pt c2b25pu c2b25pv c2b25pw c2b25px c2b25py c2b25pz c2b25ps0 c2b25ps1 c2b25ps2 c2b25ps3 c2b25ps4 c2b25ps5 c2b25ps6 c2b25ps7 c2b25ps8 c2b25ps9 c2b25psb c2b25psc c2b25psd c2b25pse c2b25psf c2b25psg c2b25psh c2b25psj c2b25psk c2b25psm c2b25psn c2b25psp c2b25psq c2b25psr c2b25pss c2b25pst c2b25psu c2b25psv c2b25psw c2b25psx c2b25psy c2b25psz /); is_deeply(\@list, [qw/ c2b /]); }; done_testing; Geohash-0.04/t/007_split.t000644 000765 000765 00000000717 12032470311 014260 0ustar00koko000000 000000 use strict; use warnings; use Test::More; use Geohash; my $gh = Geohash->new; my @list = $gh->split('c2b25ps'); is_deeply(\@list, [ qw/ c2b25ps0 c2b25ps1 c2b25ps2 c2b25ps3 c2b25ps4 c2b25ps5 c2b25ps6 c2b25ps7 c2b25ps8 c2b25ps9 c2b25psb c2b25psc c2b25psd c2b25pse c2b25psf c2b25psg c2b25psh c2b25psj c2b25psk c2b25psm c2b25psn c2b25psp c2b25psq c2b25psr c2b25pss c2b25pst c2b25psu c2b25psv c2b25psw c2b25psx c2b25psy c2b25psz / ]); done_testing; Geohash-0.04/t/008_validate.t000644 000765 000765 00000000534 12032470316 014721 0ustar00koko000000 000000 use strict; use warnings; use Test::More; use Geohash; my $gh = Geohash->new; ok(not $gh->validate('')); ok(not $gh->validate()); ok(not $gh->validate('a')); ok(not $gh->validate('c2b25psa')); ok($gh->validate('c2b25ps')); ok($gh->validate('c2b25pszzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz')); done_testing; Geohash-0.04/t/00_compile.t000644 000765 000765 00000000103 12032470326 014461 0ustar00koko000000 000000 use strict; use Test::More tests => 1; BEGIN { use_ok 'Geohash' } Geohash-0.04/lib/Geohash.pm000644 000765 000765 00000024070 12037161657 014606 0ustar00koko000000 000000 package Geohash; use strict; use warnings; our $VERSION = '0.04'; use Exporter 'import'; our @EXPORT_OK = qw( ADJ_TOP ADJ_RIGHT ADJ_LEFT ADJ_BOTTOM ); our %EXPORT_TAGS = (adjacent => \@EXPORT_OK); BEGIN { my @classes = qw( Geo::Hash::XS Geohash::backendPP ); if (my $backend = $ENV{PERL_GEOHASH_BACKEND}) { if ($backend eq 'Geo::Hash') { @classes = qw( Geohash::backendPP ); } elsif ($backend eq '+Geo::Hash') { @classes = qw( Geo::Hash ); } else { @classes = ( $backend ); } } local $@; my $class; for (@classes) { $class = $_; last if $class eq 'Geohash::backendPP'; eval "use $class";## no critic last unless $@; } unless ($class eq 'Geohash::backendPP') { die $@ if $@; } sub backend_class { $class } no strict 'refs'; *ADJ_RIGHT = sub { &{"$class\::ADJ_RIGHT"} }; *ADJ_LEFT = sub { &{"$class\::ADJ_LEFT"} }; *ADJ_TOP = sub { &{"$class\::ADJ_TOP"} }; *ADJ_BOTTOM = sub { &{"$class\::ADJ_BOTTOM"} }; } sub new { my($class) = @_; my $backend = $class->backend_class->new; bless { backend => $backend, }, $class; } for my $method (qw/ encode decode decode_to_interval adjacent neighbors precision /) { my $code = sub { my $self = shift; $self->{backend}->$method(@_); }; no strict 'refs'; *{$method} = $code; } my @ENC = qw( 0 1 2 3 4 5 6 7 8 9 b c d e f g h j k m n p q r s t u v w x y z ); my %ENC_MAP = map { $_ => 1 } @ENC; sub _merge_strip_last_char { my($self, $geohash) = @_; my @results; if (length($geohash || '') < 2) { return ($geohash); } my($parent_geohash, $last_char) = $geohash =~ /^(.+)(.)$/; if ($last_char eq $ENC[0]) { $self->{cache}{$parent_geohash}{$last_char}++; } elsif ($last_char eq $ENC[-1]) { $self->{cache}{$parent_geohash}{$last_char}++; if (scalar(keys %{ $self->{cache}{$parent_geohash} }) == scalar(@ENC)) { push @results, $self->_merge_strip_last_char($parent_geohash); } else { push @results, map { "$parent_geohash$_" } keys %{ $self->{cache}{$parent_geohash} }; } delete $self->{cache}{$parent_geohash}; } else { if ($self->{cache}{$parent_geohash} && $ENC_MAP{$last_char}) { $self->{cache}{$parent_geohash}{$last_char}++; } else { push @results, $geohash; } } return @results; } sub merge { my $self = shift; my @geohashes = sort @_; $self->{cache} = +{}; my @results; for my $geohash (@geohashes) { push @results, $self->_merge_strip_last_char($geohash); } delete $self->{cache}; sort @results; } sub split { my($self, $geohash) = @_; map { "$geohash$_" } @ENC; } sub validate { my($self, $geohash) = @_; $geohash && $geohash =~ /^[0123456789bcdefghjkmnpqrstuvwxyz]+$/; } { package Geohash::backendPP; use strict; use warnings; use parent 'Geo::Hash'; use Carp; # https://github.com/yappo/Geo--Hash/tree/feature-geo_hash_xs use constant ADJ_RIGHT => 0; use constant ADJ_LEFT => 1; use constant ADJ_TOP => 2; use constant ADJ_BOTTOM => 3; my @NEIGHBORS = ( [ "bc01fg45238967deuvhjyznpkmstqrwx", "p0r21436x8zb9dcf5h7kjnmqesgutwvy" ], [ "238967debc01fg45kmstqrwxuvhjyznp", "14365h7k9dcfesgujnmqp0r2twvyx8zb" ], [ "p0r21436x8zb9dcf5h7kjnmqesgutwvy", "bc01fg45238967deuvhjyznpkmstqrwx" ], [ "14365h7k9dcfesgujnmqp0r2twvyx8zb", "238967debc01fg45kmstqrwxuvhjyznp" ] ); my @BORDERS = ( [ "bcfguvyz", "prxz" ], [ "0145hjnp", "028b" ], [ "prxz", "bcfguvyz" ], [ "028b", "0145hjnp" ] ); sub adjacent { my ( $self, $hash, $where ) = @_; my $hash_len = length $hash; croak "PANIC: hash too short!" unless $hash_len >= 1; my $base; my $last_char; my $type = $hash_len % 2; if ( $hash_len == 1 ) { $base = ''; $last_char = $hash; } else { ( $base, $last_char ) = $hash =~ /^(.+)(.)$/; if ($BORDERS[$where][$type] =~ /$last_char/) { my $tmp = $self->adjacent($base, $where); substr($base, 0, length($tmp)) = $tmp; } } return $base . $ENC[ index($NEIGHBORS[$where][$type], $last_char) ]; } sub neighbors { my ( $self, $hash, $around, $offset ) = @_; $around ||= 1; $offset ||= 0; my $last_hash = $hash; my $i = 1; while ( $offset-- > 0 ) { my $top = $self->adjacent( $last_hash, ADJ_TOP ); my $left = $self->adjacent( $top, ADJ_LEFT ); $last_hash = $left; $i++; } my @list; while ( $around-- > 0 ) { my $max = 2 * $i - 1; $last_hash = $self->adjacent( $last_hash, ADJ_TOP ); push @list, $last_hash; for ( 0..( $max - 1 ) ) { $last_hash = $self->adjacent( $last_hash, ADJ_RIGHT ); push @list, $last_hash; } for ( 0..$max ) { $last_hash = $self->adjacent( $last_hash, ADJ_BOTTOM ); push @list, $last_hash; } for ( 0..$max ) { $last_hash = $self->adjacent( $last_hash, ADJ_LEFT ); push @list, $last_hash; } for ( 0..$max ) { $last_hash = $self->adjacent( $last_hash, ADJ_TOP ); push @list, $last_hash; } $i++; } return @list; } } 1; __END__ =head1 NAME Geohash - Great all in one Geohash library =head1 SYNOPSIS simple wrapper use Geohash; my $gh = Geohash->new(); my $hash = $gh->encode( $lat, $lon ); # default precision = 32 my $hash = $gh->encode( $lat, $lon, $precision ); my ($lat, $lon) = $gh->decode( $hash ); my ($lat_range, $lon_range) = $gh->decode_to_interval( $hash ); my $precision = $gh->precision($lat, $lon); compatible with Pure Perl and XS my $adjacent_hash = $gh->adjacent($hash, $where); my @list_of_geohashes = $gh->neighbors($hash, $around, $offset); specific utilities of Geohash.pm my @list_of_merged_geohashes = $gh->merge(@list_of_geohashes); my @list_of_geohashes = $gh->split(@list_of_merged_geohashes); my $bool = $gh->validate( $geohash ); fource use pp BEGIN { $ENV{PERL_GEOHASH_BACKEND} = 'Geo::Hash' } use Geohash; fource use xs BEGIN { $ENV{PERL_GEOHASH_BACKEND} = 'Geo::Hash::XS' } use Geohash; =head1 DESCRIPTION L can handle easily Geohash. Geohash uses L or L as a backend module. You can easy choose of Pure-Perl implement or XS implement. In addition, we have also been added useful utility methods. =head1 Why did you not used the name of Geo::Hash::Any? Geohash official name is not I. It should not be separated by I<::>. And I think of I<*::Any> namespace is not preferable. I think so no problem with increasing the namespace if a namespace that can be used to implement and intuitive. =head1 METHODS =head2 $gh = Geohash->new() =head2 $hash = $gh->encode($lat, $lon[, $precision]) Encodes the given C<$lat> and C<$lon> to a geohash. If C<$precision> is not given, automatically adjusts the precision according the the given C<$lat> and C<$lon> values. If you do not want Geohash to spend time calculating this, explicitly specify C<$precision>. =head2 ($lat, $lon) = $gh->decode( $hash ) Decodes $hash to $lat and $lon =head2 ($lat_range, $lon_range) = $gh->decode_to_interval( $hash ) Like C but C decodes $hash to $lat_range and $lon_range. Each range is a reference to two element arrays which contains the upper and lower bounds. =head2 $precision = $gh->precision($lat, $lon) Returns the apparent required precision to describe the given latitude and longitude. =head2 $adjacent_hash = $gh->adjacent($hash, $where) Returns the adjacent geohash. C<$where> denotes the direction, so if you want the block to the right of C<$hash>, you say: use Geohash qw(ADJ_RIGHT); my $gh = Geohash->new(); my $adjacent = $gh->adjacent( $hash, ADJ_RIGHT ); =head2 @list_of_geohashes = $gh->neighbors($hash, $around, $offset) Returns the list of neighbors (the blocks surrounding $hash) =head2 @list_of_merged_geohashes = $gh->merge(@list_of_geohashes) Merged with the larger area from geohash list. And remove duplicated geohash in @list_of_geohashes. my @list = $gh->merge(qw/ c2b25ps0 c2b25ps1 c2b25ps2 c2b25ps3 c2b25ps4 c2b25ps5 c2b25ps6 c2b25ps7 c2b25ps8 c2b25ps9 c2b25psb c2b25psc c2b25psd c2b25pse c2b25psf c2b25psg c2b25psh c2b25psj c2b25psk c2b25psm c2b25psn c2b25psp c2b25psq c2b25psr c2b25pss c2b25pst c2b25psu c2b25psv c2b25psw c2b25psx c2b25psy c2b25psz /); is($list[0], 'c2b25ps'); =head2 @list_of_geohashes = $gh->split(@list_of_merged_geohashes) geohash splitter. my @list = $gh->split('c2b25ps'); is_deeply(\@list, [ qw/ c2b25ps0 c2b25ps1 c2b25ps2 c2b25ps3 c2b25ps4 c2b25ps5 c2b25ps6 c2b25ps7 c2b25ps8 c2b25ps9 c2b25psb c2b25psc c2b25psd c2b25pse c2b25psf c2b25psg c2b25psh c2b25psj c2b25psk c2b25psm c2b25psn c2b25psp c2b25psq c2b25psr c2b25pss c2b25pst c2b25psu c2b25psv c2b25psw c2b25psx c2b25psy c2b25psz / ]); =head2 $bool = $gh->validate($geohash) Verify correct as geohash. ok($gh->validate('c2b25ps0'); ok(not $gh->validate('a'); # can not use 'a' ok(not $gh->validate(); # required option =head1 CONSTANTS =head2 ADJ_LEFT, ADJ_RIGHT, ADJ_TOP, ADJ_BOTTOM Used to specify the direction in C =head1 AUTHOR Kazuhiro Osawa Eyappo {at} shibuya {dot} plE =head1 SEE ALSO L, L, L, L =head1 THANKS TO dirkus, tokuhirom, nipotan =head1 LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Geohash-0.04/inc/Module/000755 000765 000765 00000000000 12037161662 014113 5ustar00koko000000 000000 Geohash-0.04/inc/Pod/000755 000765 000765 00000000000 12037161662 013410 5ustar00koko000000 000000 Geohash-0.04/inc/Pod/Markdown.pm000644 000765 000765 00000014141 12037161661 015530 0ustar00koko000000 000000 #line 1 use 5.008; use strict; use warnings; package Pod::Markdown; BEGIN { $Pod::Markdown::VERSION = '1.110730'; } # ABSTRACT: Convert POD to Markdown use parent qw(Pod::Parser); sub initialize { my $self = shift; $self->SUPER::initialize(@_); $self->_private; $self; } sub _private { my $self = shift; $self->{_MyParser} ||= { Text => [], # final text Indent => 0, # list indent levels counter ListType => '-', # character on every item searching => '' , # what are we searching for? (title, author etc.) Title => undef, # page title Author => undef, # page author }; } sub as_markdown { my ($parser, %args) = @_; my $data = $parser->_private; my $lines = $data->{Text}; my @header; if ($args{with_meta}) { @header = $parser->_build_markdown_head; } join("\n" x 2, @header, @{$lines}); } sub _build_markdown_head { my $parser = shift; my $data = $parser->_private; my $paragraph = ''; if (defined $data->{Title}) { $paragraph .= sprintf '[[meta title="%s"]]', $data->{Title}; } if (defined $data->{Author}) { $paragraph .= "\n" . sprintf '[[meta author="%s"]]', $data->{Author}; } return $paragraph; } sub _save { my ($parser, $text) = @_; my $data = $parser->_private; $text = $parser->_indent_text($text); push @{ $data->{Text} }, $text; return; } sub _unsave { my $parser = shift; my $data = $parser->_private; return pop @{ $data->{Text} }; } sub _indent_text { my ($parser, $text) = @_; my $data = $parser->_private; my $level = $data->{Indent}; my $indent = undef; if ($level > 0) { $level--; } $indent = ' ' x ($level * 4); my @lines = map { $indent . $_; } split(/\n/, $text); return wantarray ? @lines : join("\n", @lines); } sub _clean_text { my $text = $_[1]; my @trimmed = grep { $_; } split(/\n/, $text); return wantarray ? @trimmed : join("\n", @trimmed); } sub command { my ($parser, $command, $paragraph, $line_num) = @_; my $data = $parser->_private; # cleaning the text $paragraph = $parser->_clean_text($paragraph); # is it a header ? if ($command =~ m{head(\d)}xms) { my $level = $1; $paragraph = $parser->interpolate($paragraph, $line_num); # the headers never are indented $parser->_save($parser->format_header($level, $paragraph)); if ($level == 1) { if ($paragraph =~ m{NAME}xmsi) { $data->{searching} = 'title'; } elsif ($paragraph =~ m{AUTHOR}xmsi) { $data->{searching} = 'author'; } else { $data->{searching} = ''; } } } # opening a list ? elsif ($command =~ m{over}xms) { # update indent level $data->{Indent}++; # closing a list ? } elsif ($command =~ m{back}xms) { # decrement indent level $data->{Indent}--; $data->{searching} = ''; } elsif ($command =~ m{item}xms) { $paragraph = $parser->interpolate($paragraph, $line_num); $paragraph =~ s{^\h* \* \h*}{}xms; if ($data->{searching} eq 'listpara') { $data->{searching} = 'listheadhuddled'; } else { $data->{searching} = 'listhead'; } if (length $paragraph) { $parser->textblock($paragraph, $line_num); } } # ignore other commands return; } sub verbatim { my ($parser, $paragraph) = @_; $parser->_save($paragraph); } sub textblock { my ($parser, $paragraph, $line_num) = @_; my $data = $parser->_private; # interpolate the paragraph for embebed sequences $paragraph = $parser->interpolate($paragraph, $line_num); # clean the empty lines $paragraph = $parser->_clean_text($paragraph); # searching ? if ($data->{searching} =~ m{title|author}xms) { $data->{ ucfirst $data->{searching} } = $paragraph; $data->{searching} = ''; } elsif ($data->{searching} =~ m{listhead(huddled)?$}xms) { my $is_huddled = $1; $paragraph = sprintf '%s %s', $data->{ListType}, $paragraph; if ($is_huddled) { $paragraph = $parser->_unsave() . "\n" . $paragraph; } $data->{searching} = 'listpara'; } elsif ($data->{searching} eq 'listpara') { $data->{searching} = ''; } # save the text $parser->_save($paragraph); } sub interior_sequence { my ($seq_command, $seq_argument, $pod_seq) = @_[1..3]; my %interiors = ( 'I' => sub { return '_' . $_[1] . '_' }, # italic 'B' => sub { return '__' . $_[1] . '__' }, # bold 'C' => sub { return '`' . $_[1] . '`' }, # monospace 'F' => sub { return '`' . $_[1] . '`' }, # system path 'S' => sub { return '`' . $_[1] . '`' }, # code 'E' => sub { my $charname = $_[1]; return '<' if $charname eq 'lt'; return '>' if $charname eq 'gt'; return '|' if $charname eq 'verbar'; return '/' if $charname eq 'sol'; return "&$charname;"; }, 'L' => \&_resolv_link, ); if (exists $interiors{$seq_command}) { my $code = $interiors{$seq_command}; return $code->($seq_command, $seq_argument, $pod_seq); } else { return sprintf '%s<%s>', $seq_command, $seq_argument; } } sub _resolv_link { my ($cmd, $arg) = @_; my $text = $arg =~ s"^(.+?)\|"" ? $1 : ''; if ($arg =~ m{^http|ftp}xms) { # direct link to a URL $text ||= $arg; return sprintf '[%s](%s)', $text, $arg; } elsif ($arg =~ m{^/(.*)$}) { $text ||= $1; $text = $1; return "[$text](\#pod_$1)"; } elsif ($arg =~ m{^(\w+(?:::\w+)*)$}) { $text ||= $1; return "[$text](http://search.cpan.org/perldoc?$1)"; } else { return sprintf '%s<%s>', $cmd, $arg; } } sub format_header { my ($level, $paragraph) = @_[1,2]; sprintf '%s %s', '#' x $level, $paragraph; } 1; __END__ #line 341 Geohash-0.04/inc/Module/Install/000755 000765 000765 00000000000 12037161662 015521 5ustar00koko000000 000000 Geohash-0.04/inc/Module/Install.pm000644 000765 000765 00000030135 12037161661 016060 0ustar00koko000000 000000 #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 Cwd (); use File::Find (); use File::Path (); 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 = '1.06'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # 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 # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # 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)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; 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"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } 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; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } 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 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 ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # 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) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $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; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD 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; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _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($_[1]) <=> _version($_[2]); } # 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 - 2012 Adam Kennedy. Geohash-0.04/inc/Module/Install/AuthorTests.pm000644 000765 000765 00000002215 12037161661 020343 0ustar00koko000000 000000 #line 1 package Module::Install::AuthorTests; use 5.005; use strict; use Module::Install::Base; use Carp (); #line 16 use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.002'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } #line 42 sub author_tests { my ($self, @dirs) = @_; _add_author_tests($self, \@dirs, 0); } #line 56 sub recursive_author_tests { my ($self, @dirs) = @_; _add_author_tests($self, \@dirs, 1); } sub _wanted { my $href = shift; sub { /\.t$/ and -f $_ and $href->{$File::Find::dir} = 1 } } sub _add_author_tests { my ($self, $dirs, $recurse) = @_; return unless $Module::Install::AUTHOR; my @tests = $self->tests ? (split / /, $self->tests) : 't/*.t'; # XXX: pick a default, later -- rjbs, 2008-02-24 my @dirs = @$dirs ? @$dirs : Carp::confess "no dirs given to author_tests"; @dirs = grep { -d } @dirs; if ($recurse) { require File::Find; my %test_dir; File::Find::find(_wanted(\%test_dir), @dirs); $self->tests( join ' ', @tests, map { "$_/*.t" } sort keys %test_dir ); } else { $self->tests( join ' ', @tests, map { "$_/*.t" } sort @dirs ); } } #line 107 1; Geohash-0.04/inc/Module/Install/Base.pm000644 000765 000765 00000002147 12037161661 016734 0ustar00koko000000 000000 #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # 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->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 Geohash-0.04/inc/Module/Install/Can.pm000644 000765 000765 00000006157 12037161661 016570 0ustar00koko000000 000000 #line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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 ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # 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 236 Geohash-0.04/inc/Module/Install/Fetch.pm000644 000765 000765 00000004627 12037161661 017120 0ustar00koko000000 000000 #line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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; Geohash-0.04/inc/Module/Install/GithubMeta.pm000644 000765 000765 00000002176 12037161661 020115 0ustar00koko000000 000000 #line 1 package Module::Install::GithubMeta; use strict; use warnings; use Cwd; use base qw(Module::Install::Base); use vars qw($VERSION); $VERSION = '0.14'; sub githubmeta { my $self = shift; return unless $Module::Install::AUTHOR; return unless _under_git(); return unless $self->can_run('git'); return unless my ($git_url) = `git remote show -n origin` =~ /URL: (.*)$/m; return unless $git_url =~ /github\.com/; # Not a Github repository my $http_url = $git_url; $git_url =~ s![\w\-]+\@([^:]+):!git://$1/!; $http_url =~ s![\w\-]+\@([^:]+):!https://$1/!; $http_url =~ s!\.git$!/tree!; $self->repository( { type => 'git', url => $git_url, web => $http_url, }, ); $self->homepage( $http_url ) unless $self->homepage(); return 1; } sub _under_git { return 1 if -e '.git'; my $cwd = getcwd; my $last = $cwd; my $found = 0; while (1) { chdir '..' or last; my $current = getcwd; last if $last eq $current; $last = $current; if ( -e '.git' ) { $found = 1; last; } } chdir $cwd; return $found; } 'Github'; __END__ #line 114 Geohash-0.04/inc/Module/Install/Makefile.pm000644 000765 000765 00000027437 12037161661 017610 0ustar00koko000000 000000 #line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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 or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; 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 ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } 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 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } 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.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } 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"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $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: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $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; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; 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 544 Geohash-0.04/inc/Module/Install/Metadata.pm000644 000765 000765 00000043277 12037161661 017613 0ustar00koko000000 000000 #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract 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 author }; *authors = \&author; 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; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } 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 really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } 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"); } $self->{values}{all_from} = $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) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $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 _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $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; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', 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()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => '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, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; 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 one bugtracker 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+(v?[\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; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # 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; Geohash-0.04/inc/Module/Install/ReadmeFromPod.pm000644 000765 000765 00000001624 12037161661 020545 0ustar00koko000000 000000 #line 1 package Module::Install::ReadmeFromPod; use 5.006; use strict; use warnings; use base qw(Module::Install::Base); use vars qw($VERSION); $VERSION = '0.12'; sub readme_from { my $self = shift; return unless $self->is_admin; my $file = shift || $self->_all_from or die "Can't determine file to make readme_from"; my $clean = shift; print "Writing README from $file\n"; require Pod::Text; my $parser = Pod::Text->new(); open README, '> README' or die "$!\n"; $parser->output_fh( *README ); $parser->parse_file( $file ); if ($clean) { $self->clean_files('README'); } return 1; } sub _all_from { my $self = shift; return unless $self->admin->{extensions}; my ($metadata) = grep { ref($_) eq 'Module::Install::Metadata'; } @{$self->admin->{extensions}}; return unless $metadata; return $metadata->{values}{all_from} || ''; } 'Readme!'; __END__ #line 112 Geohash-0.04/inc/Module/Install/ReadmeMarkdownFromPod.pm000644 000765 000765 00000003243 12037161661 022247 0ustar00koko000000 000000 #line 1 package Module::Install::ReadmeMarkdownFromPod; use 5.006; use strict; use warnings; our $VERSION = '0.03'; use base qw(Module::Install::Base); sub readme_markdown_from { my ($self, $file, $clean) = @_; return unless $Module::Install::AUTHOR; die "syntax: readme_markdown_from $file, [$clean]\n" unless $file; # require, not use because otherwise Makefile.PL will complain if # non-authors don't have Pod::Markdown, which would be bad. require Pod::Markdown; $self->admin->copy_package('Pod::Markdown', $INC{'Pod/Markdown.pm'}); my $parser = Pod::Markdown->new; $parser->parse_from_file($file); open my $fh, '>', 'README.mkdn' or die "$!\n"; print $fh $parser->as_markdown; close $fh or die "$!\n"; return 1 unless $clean; $self->postamble(<<"END"); distclean :: license_clean license_clean: \t\$(RM_F) README.mkdn END 1; } sub readme_markdown_from_pod { my ($self, $clean) = @_; return unless $Module::Install::AUTHOR; unless ($self->Meta->{values}{all_from}) { die "set 'all_from' or use 'readme_markdown_from'\n"; } $self->readme_markdown_from($self->Meta->{values}{all_from}, $clean); } sub readme_from_pod { my ($self, $clean) = @_; return unless $Module::Install::AUTHOR; unless ($self->Meta->{values}{all_from}) { die "set 'all_from' or use 'readme_from'\n"; } $self->readme_from($self->Meta->{values}{all_from}, $clean); } sub reference_module { my ($self, $file) = @_; die "syntax: reference_module $file\n" unless $file; $self->all_from($file); $self->readme_from($file); $self->readme_markdown_from($file); } 1; __END__ #line 188 Geohash-0.04/inc/Module/Install/Repository.pm000644 000765 000765 00000004256 12037161661 020244 0ustar00koko000000 000000 #line 1 package Module::Install::Repository; use strict; use 5.005; use vars qw($VERSION); $VERSION = '0.06'; use base qw(Module::Install::Base); sub _execute { my ($command) = @_; `$command`; } sub auto_set_repository { my $self = shift; return unless $Module::Install::AUTHOR; my $repo = _find_repo(\&_execute); if ($repo) { $self->repository($repo); } else { warn "Cannot determine repository URL\n"; } } sub _find_repo { my ($execute) = @_; if (-e ".git") { # TODO support remote besides 'origin'? if ($execute->('git remote show -n origin') =~ /URL: (.*)$/m) { # XXX Make it public clone URL, but this only works with github my $git_url = $1; $git_url =~ s![\w\-]+\@([^:]+):!git://$1/!; return $git_url; } elsif ($execute->('git svn info') =~ /URL: (.*)$/m) { return $1; } } elsif (-e ".svn") { if (`svn info` =~ /URL: (.*)$/m) { return $1; } } elsif (-e "_darcs") { # defaultrepo is better, but that is more likely to be ssh, not http if (my $query_repo = `darcs query repo`) { if ($query_repo =~ m!Default Remote: (http://.+)!) { return $1; } } open my $handle, '<', '_darcs/prefs/repos' or return; while (<$handle>) { chomp; return $_ if m!^http://!; } } elsif (-e ".hg") { if ($execute->('hg paths') =~ /default = (.*)$/m) { my $mercurial_url = $1; $mercurial_url =~ s!^ssh://hg\@(bitbucket\.org/)!https://$1!; return $mercurial_url; } } elsif (-e "$ENV{HOME}/.svk") { # Is there an explicit way to check if it's an svk checkout? my $svk_info = `svk info` or return; SVK_INFO: { if ($svk_info =~ /Mirrored From: (.*), Rev\./) { return $1; } if ($svk_info =~ m!Merged From: (/mirror/.*), Rev\.!) { $svk_info = `svk info /$1` or return; redo SVK_INFO; } } return; } } 1; __END__ =encoding utf-8 #line 128 Geohash-0.04/inc/Module/Install/Win32.pm000644 000765 000765 00000003403 12037161661 016760 0ustar00koko000000 000000 #line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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; Geohash-0.04/inc/Module/Install/WriteAll.pm000644 000765 000765 00000002376 12037161661 017611 0ustar00koko000000 000000 #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # 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;