File Coverage

blib/lib/GeoHash.pm

Criterion	Covered	Total	%
statement	97	151	64.2
branch	17	30	56.6
condition	3	9	33.3
subroutine	24	29	82.7
pod	4	5	80.0
total	145	224	64.7

package GeoHash;
use strict;
use warnings;
our $VERSION = '0.01';

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 Geo::Hash );
    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 $@;
    }
    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__