File Coverage

blib/lib/Geo/GeoNames.pm

Criterion	Covered	Total	%
statement	120	160	75.0
branch	42	76	55.2
condition	23	43	53.4
subroutine	20	23	86.9
pod	7	7	100.0
total	212	309	68.6

package Geo::GeoNames;
# use utf8;
use v5.10;
use strict;
use warnings;

use Carp;
use Mojo::UserAgent;
use Scalar::Util qw/blessed/;

=encoding utf8

=head1 NAME

Geo::GeoNames - Perform geographical queries using GeoNames Web Services

=head1 VERSION

Version 1.15

=cut

our $VERSION = '1.15';

=head1 SYNOPSIS

	use Geo::GeoNames;
	my $geo = Geo::GeoNames->new(username => $ENV{'GEONAME_USER'});

	# make a query based on placename
	my $result = $geo->search(q => 'Fredrikstad', maxRows => 2);

	# print the first result
	print ' Name: ', $result->[0]->{name}, "\n";
	print ' Longitude: ', $result->[0]->{lng}, "\n";
	print ' Latitude: ', $result->[0]->{lat}, "\n";

	# Make a query based on postcode
	$result = $geo->postalcode_search(
		postalcode => '1630', maxRows => 3, style => 'FULL'
	);

=head1 DESCRIPTION

Before you start, get a free GeoNames account and enable it for
access to the free web service:

=over 4

=item * Get an account

Go to L

=item * Respond to the email

=item * Login and enable your account for free access

L

=back

Provides a perl interface to the webservices found at
L. That is, given a given placename or
postalcode, the module will look it up and return more information
(longitude, latitude, etc) for the given placename or postalcode.
Wikipedia lookups are also supported. If more than one match is found,
a list of locations will be returned.

=cut

# use vars qw($DEBUG $CACHE);

our %searches = (
	cities                              => 'cities?',
	country_code                        => 'countrycode?type=xml&',
	country_info                        => 'countryInfo?',
	earthquakes                         => 'earthquakesJSON?',
	find_nearby_placename               => 'findNearbyPlaceName?',
	find_nearby_postalcodes             => 'findNearbyPostalCodes?',
	find_nearby_streets                 => 'findNearbyStreets?',
	find_nearby_weather                 => 'findNearByWeatherXML?',
	find_nearby_wikipedia               => 'findNearbyWikipedia?',
	find_nearby_wikipedia_by_postalcode => 'findNearbyWikipedia?',
	find_nearest_address                => 'findNearestAddress?',
	find_nearest_intersection           => 'findNearestIntersection?',
	postalcode_country_info             => 'postalCodeCountryInfo?',
	postalcode_search                   => 'postalCodeSearch?',
	search                              => 'search?',
	wikipedia_bounding_box              => 'wikipediaBoundingBox?',
	wikipedia_search                    => 'wikipediaSearch?',
	get                                 => 'get?',
	hierarchy                           => 'hierarchy?',
	children                            => 'children?',
	);

#   r   = required
#   o   = optional
#   rc  = required - only one of the fields marked with rc is allowed. At least one must be present
#   om  = optional, multiple entries allowed
#   d   = deprecated - will be removed in later versions
our %valid_parameters = (
	search => {
		'q'    => 'rc',
		name    => 'rc',
		name_equals => 'rc',
		maxRows    => 'o',
		startRow    => 'o',
		country    => 'om',
		continentCode    => 'o',
		adminCode1    => 'o',
		adminCode2    => 'o',
		adminCode3    => 'o',
		fclass    => 'omd',
		featureClass    => 'om',
		featureCode => 'om',
		lang    => 'o',
		type    => 'o',
		style    => 'o',
		isNameRequired    => 'o',
		tag    => 'o',
		username => 'r',
		name_startsWith => 'o',	# TODO - should this be rc?
		countryBias => 'o',
		cities => 'om',
		operator => 'o',
		searchlang => 'o',
		charset => 'o',
		fuzzy => 'o',
		north => 'o',
		west => 'o',
		east => 'o',
		south => 'o',
		orderby => 'o',
		},
	postalcode_search => {
		postalcode    => 'rc',
		placename    => 'rc',
		country    => 'o',
		maxRows    => 'o',
		style    => 'o',
		username => 'r',
		},
	find_nearby_postalcodes => {
		lat    => 'r',
		lng    => 'r',
		radius    => 'o',
		maxRows    => 'o',
		style    => 'o',
		country    => 'o',
		username => 'r',
		},
	postalcode_country_info => {
		username => 'r',
		},
	find_nearby_placename => {
		lat    => 'r',
		lng    => 'r',
		radius    => 'o',
		style    => 'o',
		maxRows    => 'o',
		lang => 'o',
		cities => 'o',
		username => 'r',
		},
	find_nearest_address => {
		lat    => 'r',
		lng    => 'r',
		username => 'r',
		},
	find_nearest_intersection => {
		lat    => 'r',
		lng    => 'r',
		username => 'r',
		},
	find_nearby_streets => {
		lat    => 'r',
		lng    => 'r',
		username => 'r',
		},
	find_nearby_wikipedia => {
		lang    => 'o',
		lat    => 'r',
		lng    => 'r',
		radius    => 'o',
		maxRows    => 'o',
		country    => 'o',
		username => 'r',
		},
	find_nearby_wikipedia_by_postalcode => {
		postalcode => 'r',
		country    => 'r',
		radius     => 'o',
		maxRows    => 'o',
		username   => 'r',
		},
	wikipedia_search => {
		'q'      => 'r',
		lang     => 'o',
		title    => 'o',
		maxRows  => 'o',
		username => 'r',
		},
	wikipedia_bounding_box => {
		south    => 'r',
		north    => 'r',
		east     => 'r',
		west     => 'r',
		lang     => 'o',
		maxRows  => 'o',
		username => 'r',
		},
	country_info => {
		country  => 'o',
		lang     => 'o',
		username => 'r',
		},
	country_code => {
		lat      => 'r',
		lng      => 'r',
		lang     => 'o',
		radius   => 'o',
		username => 'r',
		},
	find_nearby_weather => {
		lat      => 'r',
		lng      => 'r',
		username => 'r',
		},
	cities => {
		north      => 'r',
		south      => 'r',
		east       => 'r',
		west       => 'r',
		lang       => 'o',
		maxRows    => 'o',
		username   => 'r',
		},
	earthquakes => {
		north           => 'r',
		south           => 'r',
		east            => 'r',
		west            => 'r',
		date            => 'o',
		minMagnitude    => 'o',
		maxRows         => 'o',
		username        => 'r',
		},
	get => {
		geonameId => 'r',
		lang      => 'o',
		style     => 'o',
		username  => 'r',
		},
	hierarchy => {
		geonameId => 'r',
		username  => 'r',
		style     => 'o',
		},
	children => {
		geonameId => 'r',
		username  => 'r',
		style     => 'o',
		},
	);

sub new {
	my $class = shift;
	my %args = (ref($_[0]) eq 'HASH') ? %{$_[0]} : @_;

	if(!defined($class)) {
		# Using Geo::GeoNames->new(), not Geo::GeoNames::new()
		# carp(__PACKAGE__, ' use ->new() not ::new() to instantiate');
		# return;

		# FIXME: this only works when no arguments are given
		$class = __PACKAGE__;
	} elsif(ref($class)) {
		# clone the given object
		return bless { %{$class}, %args }, ref($class);
	}

	croak <<"HERE" unless length $args{username};
You must specify a GeoNames username to use Geo::GeoNames.
See http://www.geonames.org/export/web-services.html
HERE

	my $self = bless { _functions => \%searches, %args }, $class;

	# $self->username( $args{username} );
	$self->url( $args{url} // $self->default_url() );

	croak 'Illegal ua object, needs either a Mojo::UserAgent or an LWP::UserAgent derived object'
	   if exists $args{ua} && !(ref $args{ua} && blessed($args{ua}) && ( $args{ua}->isa('Mojo::UserAgent') || $args{ua}->isa('LWP::UserAgent') ) );
	$self->ua($args{ua} || $self->default_ua );

	# (exists($args{debug})) ? $DEBUG = $args{debug} : 0;
	# (exists($args{cache})) ? $CACHE = $args{cache} : 0;
	# $self->{_functions} = \%searches;

	return $self;
}

sub username {
	my( $self, $username ) = @_;

	$self->{username} = $username if @_ == 2;

	$self->{username};
}

=head2 ua

Accessor method to get and set UserAgent object used internally. You
can call I for example, to get the proxy information from
environment variables:

    $geo_coder->ua()->env_proxy(1);

You can also set your own User-Agent object:

    use LWP::UserAgent::Throttled;
    $geo_coder->ua(LWP::UserAgent::Throttled->new());

=cut

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

sub default_ua
{
	my $ua = Mojo::UserAgent->new();
	$ua->on( error => sub { carp "Can't get request" } );
	return $ua;
}

sub default_url { 'http://api.geonames.org' }

sub url {
	my( $self, $url ) = @_;

	$self->{url} = $url if @_ == 2;

	$self->{url};
}

sub _build_request_url {
	my( $self, $request, @args ) = @_;
	my $hash = { @args, username => $self->username };
	my $request_url = $self->url . '/' . $searches{$request};

	# check to see that mandatory arguments are present
	my $conditional_mandatory_flag = 0;
	my $conditional_mandatory_required = 0;
	foreach my $arg (keys %{$valid_parameters{$request}}) {
		my $flags = $valid_parameters{$request}->{$arg};
		if($flags =~ /d/ && exists($hash->{$arg})) {
			carp("Argument $arg is deprecated.");
			}
		$flags =~ s/d//g;
		if($flags eq 'r' && !exists($hash->{$arg})) {
			carp("Mandatory argument $arg is missing!");
			}
		if($flags !~ /m/ && exists($hash->{$arg}) && ref($hash->{$arg})) {
			carp("Argument $arg cannot have multiple values.");
			}
		if($flags eq 'rc') {
			$conditional_mandatory_required = 1;
			if(exists($hash->{$arg})) {
				$conditional_mandatory_flag++;
				}
			}
		}

	if($conditional_mandatory_required == 1 && $conditional_mandatory_flag != 1) {
		carp("Invalid number of mandatory arguments (there can be only one)");
		}
	foreach my $key (sort keys(%$hash)) {
		carp("Invalid argument $key") if(!defined($valid_parameters{$request}->{$key}));
		my @vals = ref($hash->{$key}) ? @{$hash->{$key}} : $hash->{$key};
		no warnings 'uninitialized';
		$request_url .= join('', map { "$key=$_&" } sort @vals );
		}

	chop($request_url); # lose the trailing &
	return $request_url;
	}

sub _parse_xml_result {
	require XML::Simple;
	my( $self, $geonamesresponse, $single_result ) = @_;
	my @result;
	my $xmlsimple = XML::Simple->new;
	my $xml = $xmlsimple->XMLin( $geonamesresponse, KeyAttr => [], ForceArray => 1 );

	if ($xml->{'status'}) {
		carp 'GeoNames error: ', $xml->{'status'}->[0]->{message};
		return [];
	}

	$xml = { geoname => [ $xml ], totalResultsCount => '1' } if $single_result;

	my $i = 0;
	foreach my $element (keys %{$xml}) {
		next if (ref($xml->{$element}) ne 'ARRAY');
		foreach my $list (@{$xml->{$element}}) {
			next if (ref($list) ne 'HASH');
			foreach my $attribute (%{$list}) {
				next if !defined($list->{$attribute}->[0]);
				$result[$i]->{$attribute} = (scalar @{$list->{$attribute}} == 1 ? $list->{$attribute}->[0] : $list->{$attribute});
				}
			$i++;
			}
		}
	return \@result;
	}

sub _parse_json_result {
	require JSON::MaybeXS;
	my( $self, $geonamesresponse ) = @_;

	return JSON::MaybeXS->new->utf8->decode($geonamesresponse);
}

sub _parse_text_result {
	my( $self, $geonamesresponse ) = @_;
	my @result;
	$result[0]->{Result} = $geonamesresponse;
	return \@result;
}

sub _request {
	my ($self, $request_url) = @_;

	if($self->{'logger'}) {
		$self->{'logger'}->trace('> ', ref($self), ": _request: $request_url");
	}
	my $res = $self->{ua}->get($request_url);

	# Handle Mojo::UserAgent response
	if($res->can('res')) {
		my $response = $res->res();
		unless($response->is_success) {
			my $code = $response->code() || 'unknown';
			my $message = $response->message() || 'HTTP request failed';
			carp "HTTP request failed: $code $message for URL: $request_url";
			return undef;
		}
		return $response;
	}

	# Handle LWP::UserAgent response
	unless ($res->is_success()) {
		my $code = $res->code() || 'unknown';
		my $message = $res->message() || 'HTTP request failed';
		carp "HTTP request failed: $code $message for URL: $request_url";
		return undef;
	}

	return $res->can('res') ? $res->res() : $res;
}

sub _do_search {
	my( $self, $searchtype, @args ) = @_;

	my $request_url = $self->_build_request_url( $searchtype, @args );
	my $response = $self->_request($request_url);

	# Return empty array if request failed
	return [] unless defined $response;

	# Verify HTTP status code
	my $status_code = $response->code();
	unless ($status_code >= 200 && $status_code < 300) {
		carp "HTTP error: received status code $status_code for URL: $request_url";
		return [];
	}

	# check mime-type to determine which parse method to use.
	# we accept text/xml, text/plain (how do see if it is JSON or not?)
	my $mime_type = $response->headers->content_type || '';

	# Extract just the base MIME type without parameters (e.g., charset)
	my $base_mime_type = $mime_type;
	$base_mime_type =~ s/;.*$//;	# Remove everything after semicolon
	$base_mime_type =~ s/^\s+|\s+$//g;	# Trim whitespace

	my $body = $response->can('body') ? $response->body() : $response->content;

	# Check for XML response
	if($base_mime_type eq 'text/xml' || $base_mime_type eq 'application/xml') {
		return $self->_parse_xml_result( $body, $searchtype eq 'get' );
	}

	# Check for JSON response
	if($base_mime_type eq 'application/json') {
		# a JSON object always start with a left-brace {
		# according to http://json.org/
		if( $body =~ m/\A\{/ ) {
			if ($response->can('json')) {
				return $response->json;
			} else {
				return $self->_parse_json_result( $body );
			}
		} else {
			return $self->_parse_text_result( $body );
		}
	}

	# Unexpected MIME type
	if($base_mime_type eq 'text/plain') {
		carp "Unexpected mime type [text/plain]. Response body: ", substr($body, 0, 200);
	} elsif($base_mime_type eq 'text/html') {
		carp "Received HTML response instead of expected data format. This may indicate an error page or service unavailability.";
	} else {
		carp "Unsupported mime type [$mime_type]. Expected text/xml or application/json.";
	}
}

sub geocode {
	my( $self, $q ) = @_;
	$self->search( 'q' => $q );
}

sub AUTOLOAD {
	my $self = shift;
	# my $type = ref($self) || croak "$self is not an object";
	ref($self) || croak "$self is not an object";
	my $name = our $AUTOLOAD;
	$name =~ s/.*://;

	unless (exists $self->{_functions}->{$name}) {
		croak "No such method '$AUTOLOAD'";
		}

	return($self->_do_search($name, @_));
}

sub DESTROY { 1 }

1;

__END__