File Coverage

blib/lib/Geo/Coder/Googlev3.pm

Criterion	Covered	Total	%
statement	103	105	98.1
branch	41	48	85.4
condition	6	9	66.6
subroutine	17	17	100.0
pod	6	8	75.0
total	173	187	92.5

# -*- mode:perl; coding:iso-8859-1 -*-

#
# Author: Slaven Rezic
#
# Copyright (C) 2010,2011,2013,2014,2017 Slaven Rezic. All rights reserved.
# This package is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#

package Geo::Coder::Googlev3;

use strict;
use vars qw($VERSION);
our $VERSION = '0.16';

use Carp            ('croak');
use Encode          ();
use JSON::XS        ();
use LWP::UserAgent  ();
use URI		    ();
use URI::QueryParam ();

sub new {
    my($class, %args) = @_;
    my $self = bless {}, $class;
    $self->{ua}       = delete $args{ua} ||
        LWP::UserAgent->new(
                            agent     => __PACKAGE__ . "/$VERSION libwww-perl/$LWP::VERSION",
                            env_proxy => 1,
                            timeout   => 15,
                           );
    $self->{region}   = delete $args{region} || delete $args{gl};
    $self->{language} = delete $args{language};
    {
        my $sensor;
        if ($args{sensor}) {
            $sensor = delete $args{sensor};
            if ($sensor !~ m{^(false|true)$}) {
                croak "sensor argument has to be either 'false' or 'true'";
            }
        }
        $self->{sensor} = $sensor;
    }
    if ($args{bounds}) {
        $self->bounds(delete $args{bounds});
    }
    $self->{key} = delete $args{key};
    $self->{use_https} = delete $args{use_https};
    croak "Unsupported arguments: " . join(" ", %args) if %args;
    $self;
}

sub ua {
    my $self = shift;
    if (@_) {
	$self->{ua} = shift;
    }
    $self->{ua};
}

sub geocode {
    my($self, %args) = @_;
    my $raw = delete $args{raw};
    my $url = $self->geocode_url(%args);
    my $ua = $self->ua;
    my $resp = $ua->get($url);
    if ($resp->is_success) {
	my $content = $resp->decoded_content(charset => "none");
	my $res = JSON::XS->new->utf8->decode($content);
        if ($raw) {
            return $res;
        }
	if ($res->{status} eq 'OK') {
            if (wantarray) {
                return @{ $res->{results} };
            } else {
                return $res->{results}->[0];
            }
        } elsif ($res->{status} eq 'ZERO_RESULTS') {
            return;
	} else {
	    croak "Fetching $url did not return OK status, but '" . $res->{status} . "'";
	}
    } else {
	croak "Fetching $url failed: " . $resp->status_line;
    }
}

# private!
sub geocode_url {
    my($self, %args) = @_;
    my $loc = $args{location};
    my $url = URI->new(($self->{use_https} ? 'https' : 'http') . '://maps.google.com/maps/api/geocode/json');
    my %url_params;
    $url_params{address}  = $loc;
    $url_params{sensor}   = $self->{sensor}   if defined $self->{sensor};
    $url_params{region}   = $self->{region}   if defined $self->{region};
    $url_params{language} = $self->{language} if defined $self->{language};
    if (defined $self->{bounds}) {
        $url_params{bounds} = join '|', map { $_->{lat}.','.$_->{lng} } @{ $self->{bounds} };
    }
    $url_params{key}      = $self->{key}      if defined $self->{key};
    while(my($k,$v) = each %url_params) {
        $url->query_param($k => Encode::encode_utf8($v));
    }
    $url = $url->as_string;
    $url;
}

sub region {
    my $self = shift;
    $self->{region} = shift if @_;
    return $self->{region};
}


sub language {
    my $self = shift;
    $self->{language} = shift if @_;
    return $self->{language};
}

sub sensor {
    my $self = shift;
    $self->{sensor} = shift if @_;
    return $self->{sensor};
}

use constant _BOUNDS_ERROR_MSG => "bounds must be in the form [{lat=>...,lng=>...}, {lat=>...,lng=>...}]";

sub bounds {
    my $self = shift;
    if (@_) {
        my $bounds = shift;
        if (ref $bounds ne 'ARRAY') {
            croak _BOUNDS_ERROR_MSG . ', but the supplied parameter is not even an array reference.';
        }
        if (@$bounds != 2) {
            croak _BOUNDS_ERROR_MSG . ', but the supplied parameter has not exactly two array elements.';
        }
        if ((grep { ref $_ eq 'HASH' && exists $_->{lng} && exists $_->{lat} ? 1 : 0 } @$bounds) != 2) {
            croak _BOUNDS_ERROR_MSG . ', but the supplied elements are not lat/lng hashes.';
        }
        $self->{bounds} = $bounds;
    }
    return $self->{bounds};
}

1;

__END__