libgeo-point-perl 0.94-1 / usr / share / perl5 / Geo / Proj.pm

# Copyrights 2005-2012 by [Mark Overmeer].
#  For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.00.

use strict;
use warnings;

package Geo::Proj;
use vars '$VERSION';
$VERSION = '0.94';


use Geo::Proj4   ();
use Carp         qw/croak/;


use overload '""'     => sub { shift->nick }
           , fallback => 1;


sub import()
{
  Geo::Proj->new
   ( nick  => 'wgs84'
   , proj4 => '+proj=latlong +datum=WGS84 +ellps=WGS84'
   );
}


my %projections;
my $defproj;

sub new(@)
{   my ($class, %args) = @_;
    my $proj   = $projections{$args{nick} || 'dead'};
    return $proj if defined $proj;

    my $self   = (bless {}, $class)->init(\%args);
    $projections{$self->nick} = $self;
    $defproj ||= $self;
    $self;
}

sub init($)
{   my ($self, $args) = @_;

    my $nick = $self->{GP_nick} = $args->{nick}
        or croak "ERROR: nick required";

    $self->{GP_srid} = $args->{srid};

    my $proj4 = $args->{proj4}
        or croak "ERROR: proj4 parameter required";

    if(ref $proj4 eq 'ARRAY')
    {   $proj4   = Geo::Proj4->new(@$proj4);
        croak "ERROR: cannot create proj4: ".Geo::Proj4->error
            unless $proj4;
    }
    elsif(!ref $proj4)
    {   $proj4   = Geo::Proj4->new($proj4);
        croak "ERROR: cannot create proj4: ".Geo::Proj4->error
            unless $proj4;
    }
    $self->{GP_proj4} = $proj4;
    $self->{GP_name}  = $args->{name};
    $self;
}


sub nick() {shift->{GP_nick}}


sub name()
{   my $self = shift;
    my $name = $self->{GP_name};
    return $name if defined $name;

    my $proj = $self->proj4;
    my $abbrev = $proj->projection
       or return $self->{nick};

    my $def    = $proj->type($abbrev);
    $def->{description};
}


sub proj4(;$)
{   my $thing = shift;
    return $thing->{GP_proj4} unless @_;

    my $proj  = $thing->projection(shift) or return undef;
    $proj->proj4;
}


sub srid() {shift->{GP_srid}}


sub projection($)
{   my $which = $_[1];
    UNIVERSAL::isa($which, __PACKAGE__) ? $which : $projections{$which};
}


sub defaultProjection(;$)
{   my $thing = shift;
    if(@_)
    {   my $proj = shift;
        $defproj = ref $proj ? $proj : $thing->projection($proj);
    }
    $defproj;
}


sub listProjections() { sort keys %projections }


sub dumpProjections(;$)
{   my $class = shift;
    my $fh    = shift || select;

    my $default = $class->defaultProjection;
    my $defnick = defined $default ? $default->nick : '';

    foreach my $nick ($class->listProjections)
    {   my $proj = $class->projection($nick);
        my $name = $proj->name;
        my $norm = $proj->proj4->normalized;
        $fh->print("$nick: $name".($defnick eq $nick ? ' (default)':'')."\n");
        $fh->print("    $norm\n") if $norm ne $name;
    }
}


sub to($@)
{   my $thing   = shift;
    my $myproj4 = ref $thing ? $thing->proj4 : __PACKAGE__->proj4(shift);
    my $toproj4 = __PACKAGE__->proj4(shift);
    $myproj4->transform($toproj4, shift);
}


# These methods may have been implemented in Geo::Point, however may get
# supported by any external library later.  Knowledge about projections
# is as much as possible concentrated here.


sub zoneForUTM($)
{   my ($thing, $point) = @_;
    my ($long, $lat) = $point->longlat;

    my $zone
     = ($lat >= 56 && $lat < 64)
     ? ( $long <  3   ? undef
       : $long < 12   ? 32
       :                undef
       )
     : ($lat >= 72 && $lat < 84)
     ? ( $long <  0   ? undef
       : $long <  9   ? 31
       : $long < 21   ? 33
       : $long < 33   ? 35
       : $long < 42   ? 37
       :                undef
       )
     : undef;

    my $meridian = int($long/6)*6 + ($long < 0 ? -3 : +3);
    $zone      ||= int(($meridian+180)/6) +1;
 
    my $letter
     = ($lat < -80 || $lat > 84) ? ''
     : ('C'..'H', 'J'..'N', 'P'..'X', 'X')[ ($lat+80)/8 ];

      wantarray     ? ($zone, $letter, $meridian)
    : defined $zone ? "$zone$letter"
    : undef;
}


sub bestUTMprojection($;$)
{   my ($thing, $point) = (shift, shift);
    my $proj  = @_ ? shift : $point->proj;

    my ($zone, $letter, $meridian) = $thing->zoneForUTM($point);
    $thing->UTMprojection($proj, $zone);
}


sub UTMprojection($$)
{   my ($class, $base, $zone) = @_;

    $base   ||= $class->defaultProjection;
    my $datum = UNIVERSAL::isa($base, __PACKAGE__) ? $base->proj4->datum :$base;
    $datum  ||= 'wgs84';

    my $label = "utm$zone-\L$datum\E";
    my $proj  = "+proj=utm +zone=$zone +datum=\U$datum\E"
              . " +ellps=\U$datum\E +units=m +no_defs";

    Geo::Proj->new(nick => $label, proj4 => $proj);
}

1;