File Coverage

blib/lib/URI/geo.pm

Criterion	Covered	Total	%
statement	104	111	93.6
branch	38	54	70.3
condition	9	24	37.5
subroutine	26	26	100.0
pod	8	8	100.0
total	185	223	82.9

package URI::geo;

use warnings;
use strict;

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

use base qw( URI );

our $VERSION = '5.34';

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__