diff options
author | Norbert Preining <norbert@preining.info> | 2024-03-15 03:06:35 +0000 |
---|---|---|
committer | Norbert Preining <norbert@preining.info> | 2024-03-15 03:06:35 +0000 |
commit | 12679ab7d3c2a210f4123163671b532b8b55d5f9 (patch) | |
tree | 0060d13467186ad977f4e73488ee20dd6c0017ab /systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/geo.pm | |
parent | 62170822e034fdd3f81de7274835d0d3b0467100 (diff) |
CTAN sync 202403150306
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/geo.pm')
-rwxr-xr-x | systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/geo.pm | 418 |
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>. |