summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/geo.pm
diff options
context:
space:
mode:
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/geo.pm')
-rwxr-xr-xsystems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/geo.pm418
1 files changed, 418 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/geo.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/geo.pm
new file mode 100755
index 0000000000..da2b9517ad
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/geo.pm
@@ -0,0 +1,418 @@
+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>.