419 lines
10 KiB
Perl
419 lines
10 KiB
Perl
package URI::geo;
|
|
|
|
use warnings;
|
|
use strict;
|
|
|
|
use Carp;
|
|
use URI::Split qw( uri_split uri_join );
|
|
|
|
use base qw( URI );
|
|
|
|
our $VERSION = '5.27';
|
|
|
|
sub _MINIMUM_LATITUDE { return -90 }
|
|
sub _MAXIMUM_LATITUDE { return 90 }
|
|
sub _MINIMUM_LONGITUDE { return -180 }
|
|
sub _MAXIMUM_LONGITUDE { return 180 }
|
|
sub _MAX_POINTY_PARAMETERS { return 3 }
|
|
|
|
sub _can {
|
|
my ($can_pt, @keys) = @_;
|
|
for my $key (@keys) {
|
|
return $key if $can_pt->can($key);
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub _has {
|
|
my ($has_pt, @keys) = @_;
|
|
for my $key (@keys) {
|
|
return $key if exists $has_pt->{$key};
|
|
}
|
|
return;
|
|
}
|
|
|
|
# Try hard to extract location information from something. We handle lat,
|
|
# lon, alt as scalars, arrays containing lat, lon, alt, hashes with
|
|
# suitably named keys and objects with suitably named methods.
|
|
|
|
sub _location_of_pointy_thing {
|
|
my ($class, @parameters) = @_;
|
|
|
|
my @lat = qw( lat latitude );
|
|
my @lon = qw( lon long longitude lng );
|
|
my @ele = qw( ele alt elevation altitude );
|
|
|
|
if (ref $parameters[0]) {
|
|
my $pt = shift @parameters;
|
|
|
|
if (@parameters) {
|
|
croak q[Too many arguments];
|
|
}
|
|
|
|
if (eval { $pt->can('can') }) {
|
|
for my $m (qw( location latlong )) {
|
|
return $pt->$m() if _can($pt, $m);
|
|
}
|
|
|
|
my $latk = _can($pt, @lat);
|
|
my $lonk = _can($pt, @lon);
|
|
my $elek = _can($pt, @ele);
|
|
|
|
if (defined $latk && defined $lonk) {
|
|
return $pt->$latk(), $pt->$lonk(),
|
|
defined $elek ? $pt->$elek() : undef;
|
|
}
|
|
}
|
|
elsif ('ARRAY' eq ref $pt) {
|
|
return $class->_location_of_pointy_thing(@{$pt});
|
|
}
|
|
elsif ('HASH' eq ref $pt) {
|
|
|
|
my $latk = _has($pt, @lat);
|
|
my $lonk = _has($pt, @lon);
|
|
my $elek = _has($pt, @ele);
|
|
|
|
if (defined $latk && defined $lonk) {
|
|
return $pt->{$latk}, $pt->{$lonk},
|
|
defined $elek ? $pt->{$elek} : undef;
|
|
}
|
|
}
|
|
|
|
croak q[Don't know how to convert point];
|
|
}
|
|
else {
|
|
croak q[Need lat, lon or lat, lon, alt]
|
|
if @parameters < 2 || @parameters > _MAX_POINTY_PARAMETERS();
|
|
return my ($lat, $lon, $alt) = @parameters;
|
|
}
|
|
}
|
|
|
|
sub _num {
|
|
my ($class, $n) = @_;
|
|
if (!defined $n) {
|
|
return q[];
|
|
}
|
|
(my $rep = sprintf '%f', $n) =~ s/[.]0*$//smx;
|
|
return $rep;
|
|
}
|
|
|
|
sub new {
|
|
my ($self, @parameters) = @_;
|
|
my $class = ref $self || $self;
|
|
my $uri = uri_join 'geo', undef, $class->_path(@parameters);
|
|
return bless \$uri, $class;
|
|
}
|
|
|
|
sub _init {
|
|
my ($class, $uri, $scheme) = @_;
|
|
|
|
my $self = $class->SUPER::_init($uri, $scheme);
|
|
|
|
# Normalise at poles.
|
|
my $lat = $self->latitude;
|
|
if ($lat == _MAXIMUM_LATITUDE() || $lat == _MINIMUM_LATITUDE()) {
|
|
$self->longitude(0);
|
|
}
|
|
return $self;
|
|
}
|
|
|
|
sub location {
|
|
my ($self, @parameters) = @_;
|
|
|
|
if (@parameters) {
|
|
my ($lat, $lon, $alt) = @parameters;
|
|
return $self->latitude($lat)->longitude($lon)->altitude($alt);
|
|
}
|
|
|
|
return $self->latitude, $self->longitude, $self->altitude;
|
|
}
|
|
|
|
sub latitude {
|
|
my ($self, @parameters) = @_;
|
|
return $self->field('latitude', @parameters);
|
|
}
|
|
|
|
sub longitude {
|
|
my ($self, @parameters) = @_;
|
|
return $self->field('longitude', @parameters);
|
|
}
|
|
|
|
sub altitude {
|
|
my ($self, @parameters) = @_;
|
|
return $self->field('altitude', @parameters);
|
|
}
|
|
|
|
sub crs {
|
|
my ($self, @parameters) = @_;
|
|
return $self->field('crs', @parameters);
|
|
}
|
|
|
|
sub uncertainty {
|
|
my ($self, @parameters) = @_;
|
|
return $self->field('uncertainty', @parameters);
|
|
}
|
|
|
|
sub field {
|
|
my ($self, $name, @remainder) = @_;
|
|
my ($scheme, $auth, $v, $query, $frag) = $self->_parse;
|
|
|
|
if (!exists $v->{$name}) {
|
|
croak "No such field: $name";
|
|
}
|
|
if (!@remainder) {
|
|
return $v->{$name};
|
|
}
|
|
$v->{$name} = shift @remainder;
|
|
${$self} = uri_join $scheme, $auth, $self->_format($v), $query, $frag;
|
|
return $self;
|
|
}
|
|
|
|
{
|
|
my $pnum = qr{\d+(?:[.]\d+)?}smx;
|
|
my $num = qr{-?$pnum}smx;
|
|
my $crsp = qr{(?:;crs=(\w+))}smx;
|
|
my $uncp = qr{(?:;u=($pnum))}smx;
|
|
my $parm = qr{(?:;\w+=[^;]*)+}smx;
|
|
|
|
sub _parse {
|
|
my $self = shift;
|
|
my ($scheme, $auth, $path, $query, $frag) = uri_split ${$self};
|
|
|
|
$path =~ m{^ ($num), ($num) (?: , ($num) ) ?
|
|
(?: $crsp ) ?
|
|
(?: $uncp ) ?
|
|
( $parm ) ?
|
|
$}smx or croak 'Badly formed geo uri';
|
|
|
|
# No named captures before 5.10.0
|
|
return $scheme, $auth,
|
|
{
|
|
latitude => $1,
|
|
longitude => $2,
|
|
altitude => $3,
|
|
crs => $4,
|
|
uncertainty => $5,
|
|
parameters => (defined $6 ? substr $6, 1 : undef),
|
|
},
|
|
$query, $frag;
|
|
}
|
|
}
|
|
|
|
sub _format {
|
|
my ($class, $v) = @_;
|
|
return join q[;],
|
|
(
|
|
join q[,],
|
|
map { $class->_num($_) } @{$v}{'latitude', 'longitude'},
|
|
(defined $v->{altitude} ? ($v->{altitude}) : ())
|
|
),
|
|
(defined $v->{crs} ? ('crs=' . $class->_num($v->{crs})) : ()),
|
|
(
|
|
defined $v->{uncertainty}
|
|
? ('u=' . $class->_num($v->{uncertainty}))
|
|
: ()), (defined $v->{parameters} ? ($v->{parameters}) : ());
|
|
}
|
|
|
|
sub _path {
|
|
my ($class, @parameters) = @_;
|
|
my ($lat, $lon, $alt) = $class->_location_of_pointy_thing(@parameters);
|
|
croak 'Latitude out of range'
|
|
if $lat < _MINIMUM_LATITUDE() || $lat > _MAXIMUM_LATITUDE();
|
|
croak 'Longitude out of range'
|
|
if $lon < _MINIMUM_LONGITUDE() || $lon > _MAXIMUM_LONGITUDE();
|
|
if ($lat == _MINIMUM_LATITUDE() || $lat == _MAXIMUM_LATITUDE()) {
|
|
$lat = 0;
|
|
}
|
|
return $class->_format(
|
|
{latitude => $lat, longitude => $lon, altitude => $alt});
|
|
}
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
URI::geo - URI scheme for geo Identifiers
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use URI;
|
|
|
|
# Geo URI from textual uri
|
|
my $guri = URI->new( 'geo:54.786989,-2.344214' );
|
|
|
|
# From coordinates
|
|
my $guri = URI::geo->new( 54.786989, -2.344214 );
|
|
|
|
# Decode
|
|
my ( $lat, $lon, $alt ) = $guri->location;
|
|
my $latitude = $guri->latitude;
|
|
|
|
# Update
|
|
$guri->location( 55, -1 );
|
|
$guri->longitude( -43.23 );
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
From L<http://geouri.org/>:
|
|
|
|
More and more protocols and data formats are being extended by methods
|
|
to add geographic information. However, all of those options are tied
|
|
to that specific protocol or data format.
|
|
|
|
A dedicated Uniform Resource Identifier (URI) scheme for geographic
|
|
locations would be independent from any protocol, usable by any
|
|
software/data format that can handle generich URIs. Like a "mailto:"
|
|
URI launches your favourite mail application today, a "geo:" URI could
|
|
soon launch your favourite mapping service, or queue that location for
|
|
a navigation device.
|
|
|
|
=head1 SUBROUTINES/METHODS
|
|
|
|
=head2 C<< new >>
|
|
|
|
Create a new URI::geo. The arguments should be either
|
|
|
|
=over
|
|
|
|
=item * latitude, longitude and optionally altitude
|
|
|
|
=item * a reference to an array containing lat, lon, alt
|
|
|
|
=item * a reference to a hash with suitably named keys or
|
|
|
|
=item * a reference to an object with suitably named accessors
|
|
|
|
=back
|
|
|
|
To maximize the likelihood that you can pass in some object that
|
|
represents a geographical location and have URI::geo do the right thing
|
|
we try a number of different accessor names.
|
|
|
|
If the object has a C<latlong> method (e.g. L<Geo::Point>) we'll use that.
|
|
If there's a C<location> method we call that. Otherwise we look for
|
|
accessors called C<lat>, C<latitude>, C<lon>, C<long>, C<longitude>,
|
|
C<ele>, C<alt>, C<elevation> or C<altitude> and use them.
|
|
|
|
Often if you have an object or hash reference that represents a point
|
|
you can pass it directly to C<new>; so for example this will work:
|
|
|
|
use URI::geo;
|
|
use Geo::Point;
|
|
|
|
my $pt = Geo::Point->latlong( 48.208333, 16.372778 );
|
|
my $guri = URI::geo->new( $pt );
|
|
|
|
As will this:
|
|
|
|
my $guri = URI::geo->new( { lat => 55, lon => -1 } );
|
|
|
|
and this:
|
|
|
|
my $guri = URI::geo->new( 55, -1 );
|
|
|
|
Note that you can also create a new C<URI::geo> by passing a Geo URI to
|
|
C<URI::new>:
|
|
|
|
use URI;
|
|
|
|
my $guri = URI->new( 'geo:55,-1' );
|
|
|
|
=head2 C<location>
|
|
|
|
Get or set the location of this geo URI.
|
|
|
|
my ( $lat, $lon, $alt ) = $guri->location;
|
|
$guri->location( 55.3, -3.7, 120 );
|
|
|
|
When setting the location it is possible to pass any of the argument
|
|
types that can be passed to C<new>.
|
|
|
|
=head2 C<latitude>
|
|
|
|
Get or set the latitude of this geo URI.
|
|
|
|
=head2 C<longitude>
|
|
|
|
Get or set the longitude of this geo URI.
|
|
|
|
=head2 C<altitude>
|
|
|
|
Get or set the L<altitude|https://en.wikipedia.org/wiki/Geo_URI_scheme#Altitude> of this geo URI. To delete the altitude set it to C<undef>.
|
|
|
|
=head2 C<crs>
|
|
|
|
Get or set the L<Coordinate Reference System|https://en.wikipedia.org/wiki/Geo_URI_scheme#Coordinate_reference_systems> of this geo URI. To delete the CRS set it to C<undef>.
|
|
|
|
=head2 C<uncertainty>
|
|
|
|
Get or set the L<uncertainty|https://en.wikipedia.org/wiki/Geo_URI_scheme#Uncertainty> of this geo URI. To delete the uncertainty set it to C<undef>.
|
|
|
|
=head2 C<field>
|
|
|
|
=head1 CONFIGURATION AND ENVIRONMENT
|
|
|
|
URI::geo requires no configuration files or environment variables.
|
|
|
|
=head1 DEPENDENCIES
|
|
|
|
L<URI>
|
|
|
|
=head1 DIAGNOSTICS
|
|
|
|
=over
|
|
|
|
=item C<< Too many arguments >>
|
|
|
|
The L<new|/new> method can only accept three parameters; latitude, longitude and altitude.
|
|
|
|
=item C<< Don't know how to convert point >>
|
|
|
|
The L<new|/new> method doesn't know how to convert the supplied parameters into a URI::geo object.
|
|
|
|
=item C<< Need lat, lon or lat, lon, alt >>
|
|
|
|
The L<new|/new> method needs two (latitude and longitude) or three (latitude, longitude and altitude) parameters in a list. Any less or more than this is an error.
|
|
|
|
=item C<< No such field: %s >>
|
|
|
|
This field is not a known field for the L<URI::geo|URI::geo> object.
|
|
|
|
=item C<< Badly formed geo uri >>
|
|
|
|
The L<URI|URI> cannot be parsed as a URI
|
|
|
|
=item C<< Badly formed geo uri >>
|
|
|
|
The L<URI|URI> cannot be parsed as a URI
|
|
|
|
=item C<< Latitude out of range >>
|
|
|
|
Latitude may only be from -90 to +90
|
|
|
|
=item C<< Longitude out of range >>
|
|
|
|
Longitude may only be from -180 to +180
|
|
|
|
=back
|
|
|
|
=head1 INCOMPATIBILITIES
|
|
|
|
None reported.
|
|
|
|
=head1 BUGS AND LIMITATIONS
|
|
|
|
To report a bug, or view the current list of bugs, please visit L<https://github.com/libwww-perl/URI/issues>
|
|
|
|
=head1 AUTHOR
|
|
|
|
Andy Armstrong C<< <andy@hexten.net> >>
|
|
|
|
=head1 LICENSE AND COPYRIGHT
|
|
|
|
Copyright (c) 2009, Andy Armstrong C<< <andy@hexten.net> >>.
|
|
|
|
This module is free software; you can redistribute it and/or
|
|
modify it under the same terms as Perl itself. See L<perlartistic>.
|