<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package URI::geo;

use warnings;
use strict;

use Carp;
use URI::Split qw( uri_split uri_join );

use base qw( URI );

our $VERSION = '5.31';

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-&gt;can($key);
    }
    return;
}

sub _has {
    my ($has_pt, @keys) = @_;
    for my $key (@keys) {
        return $key if exists $has_pt-&gt;{$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-&gt;can('can') }) {
            for my $m (qw( location latlong )) {
                return $pt-&gt;$m() if _can($pt, $m);
            }

            my $latk = _can($pt, @lat);
            my $lonk = _can($pt, @lon);
            my $elek = _can($pt, @ele);

            if (defined $latk &amp;&amp; defined $lonk) {
                return $pt-&gt;$latk(), $pt-&gt;$lonk(),
                    defined $elek ? $pt-&gt;$elek() : undef;
            }
        }
        elsif ('ARRAY' eq ref $pt) {
            return $class-&gt;_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 &amp;&amp; defined $lonk) {
                return $pt-&gt;{$latk}, $pt-&gt;{$lonk},
                    defined $elek ? $pt-&gt;{$elek} : undef;
            }
        }

        croak q[Don't know how to convert point];
    }
    else {
        croak q[Need lat, lon or lat, lon, alt]
            if @parameters &lt; 2 || @parameters &gt; _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-&gt;_path(@parameters);
    return bless \$uri, $class;
}

sub _init {
    my ($class, $uri, $scheme) = @_;

    my $self = $class-&gt;SUPER::_init($uri, $scheme);

    # Normalise at poles.
    my $lat = $self-&gt;latitude;
    if ($lat == _MAXIMUM_LATITUDE() || $lat == _MINIMUM_LATITUDE()) {
        $self-&gt;longitude(0);
    }
    return $self;
}

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

    if (@parameters) {
        my ($lat, $lon, $alt) = @parameters;
        return $self-&gt;latitude($lat)-&gt;longitude($lon)-&gt;altitude($alt);
    }

    return $self-&gt;latitude, $self-&gt;longitude, $self-&gt;altitude;
}

sub latitude {
    my ($self, @parameters) = @_;
    return $self-&gt;field('latitude', @parameters);
}

sub longitude {
    my ($self, @parameters) = @_;
    return $self-&gt;field('longitude', @parameters);
}

sub altitude {
    my ($self, @parameters) = @_;
    return $self-&gt;field('altitude', @parameters);
}

sub crs {
    my ($self, @parameters) = @_;
    return $self-&gt;field('crs', @parameters);
}

sub uncertainty {
    my ($self, @parameters) = @_;
    return $self-&gt;field('uncertainty', @parameters);
}

sub field {
    my ($self, $name, @remainder) = @_;
    my ($scheme, $auth, $v, $query, $frag) = $self-&gt;_parse;

    if (!exists $v-&gt;{$name}) {
        croak "No such field: $name";
    }
    if (!@remainder) {
        return $v-&gt;{$name};
    }
    $v-&gt;{$name} = shift @remainder;
    ${$self} = uri_join $scheme, $auth, $self-&gt;_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    =&gt; $1,
            longitude   =&gt; $2,
            altitude    =&gt; $3,
            crs         =&gt; $4,
            uncertainty =&gt; $5,
            parameters  =&gt; (defined $6 ? substr $6, 1 : undef),
            },
            $query, $frag;
    }
}

sub _format {
    my ($class, $v) = @_;
    return join q[;],
        (
        join q[,],
        map { $class-&gt;_num($_) } @{$v}{'latitude', 'longitude'},
        (defined $v-&gt;{altitude} ? ($v-&gt;{altitude}) : ())
        ),
        (defined $v-&gt;{crs} ? ('crs=' . $class-&gt;_num($v-&gt;{crs})) : ()),
        (
        defined $v-&gt;{uncertainty}
        ? ('u=' . $class-&gt;_num($v-&gt;{uncertainty}))
        : ()), (defined $v-&gt;{parameters} ? ($v-&gt;{parameters}) : ());
}

sub _path {
    my ($class, @parameters) = @_;
    my ($lat, $lon, $alt) = $class-&gt;_location_of_pointy_thing(@parameters);
    croak 'Latitude out of range'
        if $lat &lt; _MINIMUM_LATITUDE() || $lat &gt; _MAXIMUM_LATITUDE();
    croak 'Longitude out of range'
        if $lon &lt; _MINIMUM_LONGITUDE() || $lon &gt; _MAXIMUM_LONGITUDE();
    if ($lat == _MINIMUM_LATITUDE() || $lat == _MAXIMUM_LATITUDE()) {
        $lat = 0;
    }
    return $class-&gt;_format(
        {latitude =&gt; $lat, longitude =&gt; $lon, altitude =&gt; $alt});
}

1;

__END__

=head1 NAME

URI::geo - URI scheme for geo Identifiers

=head1 SYNOPSIS

  use URI;

  # Geo URI from textual uri
  my $guri = URI-&gt;new( 'geo:54.786989,-2.344214' );

  # From coordinates
  my $guri = URI::geo-&gt;new( 54.786989, -2.344214 );

  # Decode
  my ( $lat, $lon, $alt ) = $guri-&gt;location;
  my $latitude = $guri-&gt;latitude;

  # Update
  $guri-&gt;location( 55, -1 );
  $guri-&gt;longitude( -43.23 );
  
=head1 DESCRIPTION

From L&lt;http://geouri.org/&gt;:

  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&lt;&lt; new &gt;&gt;

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&lt;latlong&gt; method (e.g. L&lt;Geo::Point&gt;) we'll use that.
If there's a C&lt;location&gt; method we call that. Otherwise we look for
accessors called C&lt;lat&gt;, C&lt;latitude&gt;, C&lt;lon&gt;, C&lt;long&gt;, C&lt;longitude&gt;,
C&lt;ele&gt;, C&lt;alt&gt;, C&lt;elevation&gt; or C&lt;altitude&gt; and use them.

Often if you have an object or hash reference that represents a point
you can pass it directly to C&lt;new&gt;; so for example this will work:

  use URI::geo;
  use Geo::Point;

  my $pt = Geo::Point-&gt;latlong( 48.208333, 16.372778 );
  my $guri = URI::geo-&gt;new( $pt );

As will this:

  my $guri = URI::geo-&gt;new( { lat =&gt; 55, lon =&gt; -1 } );

and this:

  my $guri = URI::geo-&gt;new( 55, -1 );

Note that you can also create a new C&lt;URI::geo&gt; by passing a Geo URI to
C&lt;URI::new&gt;:

  use URI;

  my $guri = URI-&gt;new( 'geo:55,-1' );

=head2 C&lt;location&gt;

Get or set the location of this geo URI.

  my ( $lat, $lon, $alt ) = $guri-&gt;location;
  $guri-&gt;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&lt;new&gt;.

=head2 C&lt;latitude&gt;

Get or set the latitude of this geo URI.

=head2 C&lt;longitude&gt;

Get or set the longitude of this geo URI.

=head2 C&lt;altitude&gt;

Get or set the L&lt;altitude|https://en.wikipedia.org/wiki/Geo_URI_scheme#Altitude&gt; of this geo URI. To delete the altitude set it to C&lt;undef&gt;.

=head2 C&lt;crs&gt;

Get or set the L&lt;Coordinate Reference System|https://en.wikipedia.org/wiki/Geo_URI_scheme#Coordinate_reference_systems&gt; of this geo URI. To delete the CRS set it to C&lt;undef&gt;.

=head2 C&lt;uncertainty&gt;

Get or set the L&lt;uncertainty|https://en.wikipedia.org/wiki/Geo_URI_scheme#Uncertainty&gt; of this geo URI. To delete the uncertainty set it to C&lt;undef&gt;.

=head2 C&lt;field&gt;

=head1 CONFIGURATION AND ENVIRONMENT

URI::geo requires no configuration files or environment variables.

=head1 DEPENDENCIES

L&lt;URI&gt;

=head1 DIAGNOSTICS

=over
 
=item C&lt;&lt; Too many arguments &gt;&gt;
 
The L&lt;new|/new&gt; method can only accept three parameters; latitude, longitude and altitude.
 
=item C&lt;&lt; Don't know how to convert point &gt;&gt;

The L&lt;new|/new&gt; method doesn't know how to convert the supplied parameters into a URI::geo object.

=item C&lt;&lt; Need lat, lon or lat, lon, alt &gt;&gt;

The L&lt;new|/new&gt; 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&lt;&lt; No such field: %s &gt;&gt;

This field is not a known field for the L&lt;URI::geo|URI::geo&gt; object.

=item C&lt;&lt; Badly formed geo uri &gt;&gt;

The L&lt;URI|URI&gt; cannot be parsed as a URI

=item C&lt;&lt; Badly formed geo uri &gt;&gt;

The L&lt;URI|URI&gt; cannot be parsed as a URI

=item C&lt;&lt; Latitude out of range &gt;&gt;

Latitude may only be from -90 to +90

=item C&lt;&lt; Longitude out of range &gt;&gt;

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&lt;https://github.com/libwww-perl/URI/issues&gt;

=head1 AUTHOR

Andy Armstrong  C&lt;&lt; &lt;andy@hexten.net&gt; &gt;&gt;

=head1 LICENSE AND COPYRIGHT

Copyright (c) 2009, Andy Armstrong C&lt;&lt; &lt;andy@hexten.net&gt; &gt;&gt;.

This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself. See L&lt;perlartistic&gt;.
</pre></body></html>