File Coverage

blib/lib/Geo/WKT/Simple.pm

Criterion	Covered	Total	%
statement	59	59	100.0
branch	19	22	86.3
condition			n/a
subroutine	24	24	100.0
pod	14	14	100.0
total	116	119	97.4

package Geo::WKT::Simple;
use strict;
use warnings;

use parent 'Exporter';

our $VERSION = '0.05';

our @EXPORT;
our %EXPORT_TAGS = (
    all => \@EXPORT,
    parse => [qw/
      wkt_parse_point
      wkt_parse_linestring
      wkt_parse_multilinestring
      wkt_parse_polygon
      wkt_parse_multipolygon
      wkt_parse_geometrycollection
      wkt_parse
    /],
    make => [qw/
      wkt_make_point
      wkt_make_linestring
      wkt_make_multilinestring
      wkt_make_polygon
      wkt_make_multipolygon
      wkt_make_geometrycollection
      wkt_make
    /],
);
@EXPORT = map { @{ $_ } } @EXPORT_TAGS{qw/ parse make /};

sub _parse_point {
    $_[0] =~ /^\s*(\S+)\s+(\S+)\s*$/
}

sub _parse_points_list {
    map { [ _parse_point($_) ] } split /\s*,\s*/, $_[0]
}

sub _parse_points_group {
    map {
        [ _parse_points_list($_) ]
    } split /\s*\)\s*,\s*\(\s*/, $_[0]
}

sub _parse_points_group_list {
    map {
        [ _parse_points_group($_) ]
    } split /\s*\)\s*\)\s*,\s*\(\s*\(\s*/, $_[0]
}

sub wkt_parse_point {
    my ($data) = $_[0] =~ /^point\s*\((.+)\)$/i
        or return;

    _parse_point($data);
}

sub wkt_parse_linestring {
    my ($data) = $_[0] =~ /^linestring\s*\((.+)\)$/i
        or return;

    _parse_points_list($data);
}

sub wkt_parse_multilinestring {
    my ($data) = $_[0] =~ /^multilinestring\s*\(\s*\((.+)\)\s*\)$/i
        or return;

    _parse_points_group($data);
}

sub wkt_parse_polygon {
    my ($data) = $_[0] =~ /^polygon\s*\(\s*\((.+)\)\s*\)$/i
        or return;

    _parse_points_group($data);
}

sub wkt_parse_multipolygon {
    my ($data) = $_[0] =~ /^multipolygon\s*\(\s*\(\s*\((.+)\)\s*\)\s*\)$/i
        or return;

    _parse_points_group_list($data);
}

my $ALLTYPES = 'POINT|(?:MULTI)?(?:LINESTRING|POLYGON)|GEOMETRYCOLLECTION';
sub wkt_parse_geometrycollection {
    my ($wkt) = $_[0] =~ /^geometrycollection\s*\((.+)\)$/i
        or return;

    # Copy from Geo::WKT
    my @comps;
    while ($wkt =~ /\D/) {
        last unless $wkt =~ s/^[^(]*\([^)]*\)//;
        my $take  = $&;
        while (1) {
            my @open  = $take =~ /\(/g;
            my @close = $take =~ /\)/g;
            last if @open == @close;
            $take .= $& if $wkt =~ s/^[^\)]*\)//;
        }
        my ($type) = $take =~ /^($ALLTYPES)/i;
        push @comps, [ uc($type) => [ wkt_parse($type => $take) ] ];

        $wkt =~ s/^\s*,\s*//;
    }

    @comps;
}

sub wkt_parse {
    my ($type, $wkt) = @_;

    return if $type !~ /^$ALLTYPES$/i;
    __PACKAGE__->can('wkt_parse_'.lc($type))->($wkt);
}

sub _cat {
    '('.join(', ', @_).')'
}

sub _catlinestring {
    _cat( map { "$_->[0] $_->[1]" } @_ )
}

sub _catpolygon {
    _cat( map { _catlinestring(@$_) } @_ )
}

sub wkt_make_point {
    'POINT'._cat("$_[0] $_[1]")
}

sub wkt_make_linestring {
    'LINESTRING'._catlinestring(@_)
}

sub wkt_make_multilinestring {
    'MULTILINESTRING'._catpolygon(@_)
}

sub wkt_make_polygon {
    'POLYGON'._catpolygon(@_)
}

sub wkt_make_multipolygon {
    'MULTIPOLYGON'._cat(
        map { _catpolygon(@$_) } @_
    )
}

sub wkt_make_geometrycollection {
    'GEOMETRYCOLLECTION'._cat( map { wkt_make(@$_) } @_ )
}

sub wkt_make {
    my ($type, $data) = @_;

    return if $type !~ /^$ALLTYPES$/i;
    __PACKAGE__->can('wkt_make_'.lc($type))->(@$data);
}

1;
__END__