File Coverage

blib/lib/Geo/GeoNames.pm

Criterion	Covered	Total	%
statement	120	144	83.3
branch	37	58	63.7
condition	22	32	68.7
subroutine	22	25	88.0
pod	7	7	100.0
total	208	266	78.2

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

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

use vars qw($DEBUG $CACHE);

our $VERSION = '1.13';

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',
		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',
		minMagnutide    => '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, %hash ) = @_;

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

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

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

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

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

	return $self;
	}

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

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

	$self->{username};
	}

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

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

	$self->{ua};
	}

sub default_ua {
	my $ua = Mojo::UserAgent->new;
	$ua->on( error => sub { carp "Can't get request" } );
	$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); # loose 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;
	my( $self, $geonamesresponse ) = @_;
	my @result;
	return JSON->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 ) = @_;

	my $res = $self->{ua}->get( $request_url );
	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 );

	# 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 || '';

	my $body = '';
	if ($response->can('body')) {
		$body = $response->body;
		}
	else {
		$body = $response->content;
	}

	if($mime_type =~ m(\Atext/xml;?) ) {
		return $self->_parse_xml_result( $body, $searchtype eq 'get' );
		}
	if($mime_type =~ m(\Aapplication/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 );
			}
		}

	if($mime_type eq 'text/plain') {
		carp 'Invalid mime type [text/plain]. ', $response->content();
	} else {
		carp "Invalid mime type [$mime_type]. Maybe you aren't connected.";
	}

	return [];
	}

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

sub AUTOLOAD {
	my $self = shift;
	my $type = 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__