File Coverage

blib/lib/Geo/Converter/WKT2KML.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Geo::Converter::WKT2KML;

use warnings;
use strict;
use Carp;
use XML::Simple;
$XML::Simple::PREFERRED_PARSER = 'XML::Parser';

use version; our $VERSION = qv('0.0.3');
use base 'Exporter';

our @EXPORT = qw(
    wkt2kml
    kml2wkt
);

my $coord = qr{[\+\-]?\d+(?:\.\d+)?};
my $formatter;
$formatter = {
    'point' => sub {
        '' . coordformatter( $_[0] ) . ''
    },
    'multipoint' => sub {
        $formatter->{geometrycollection}->([
            map { $formatter->{point}->([$_]) } @{$_[0]}
        ]);
    },
    'linestring' => sub {
        '' . coordformatter( $_[0] ) . ''
    },
    'multilinestring' => sub {
        $formatter->{geometrycollection}->([
            map { $formatter->{linestring}->($_) } @{$_[0]}
        ]);
    },
    'polygon' => sub {
        my @lnr;
        push @lnr, $formatter->{LinearRing}->([shift(@{$_[0]})],'outerBoundaryIs');
        push @lnr, $formatter->{LinearRing}->($_[0],'innerBoundaryIs') if ( @{ $_[0] } );
        "\n" . join( "\n", @lnr ) . "\n";
    },
    'LinearRing' => sub {
        my $bound = $_[1];
        join ( "\n", map { "<$bound>" . coordformatter( $_ ) . "" } @{$_[0]} );
    },
    'multipolygon' => sub {
        $formatter->{geometrycollection}->([
            map { $formatter->{polygon}->($_) } @{$_[0]}
        ]);
    },
    'geometrycollection' => sub {
        "\n" . join( "\n", @{$_[0]} ) . "\n"
    },
};

sub coordformatter {
    my @coords = @{$_[0]};
    join( "\n", map { my $s = $_; $s =~ s/\s+/,/g; $s } @coords );
}

sub wkt2kmlparser {
    return wkt2kmlformatter($_[1]) unless $_[0];
    $_[0] =~ s{\A                         # start of the string
               \s*                        # spaces
               (  [\(\)]                  # paren
                  | [a-zA-Z]+             # command
                  | (?:$coord\s+)+$coord  # coordinate
                  | ,                     # delimiter
               )
              }{}x;
    return wkt2kmlformatter($_[1]) if $1 eq ')';
    my $token =
      $1 eq '(' ? wkt2kmlparser( $_[0], [] ) :
      $1 ne ',' ? lc($1)
                : undef;
    push @{ $_[1] }, $token if ( defined( $token ) );
    goto &wkt2kmlparser;
}

sub wkt2kmlformatter {
    return $_[0] if ( !ref($_[0]) || $_[0]->[0] !~ /^[a-z]+$/ );

    my @args    = @{$_[0]};
    my @reslt;

    while ( my $command = shift(@args) ) {
        if ( my $format = $formatter->{$command} ) {
            push ( @reslt, $format->( shift @args ) );
        } else {
            croak "WKT $command cannot be interpreted";
        }
    }

    return @reslt > 1 ? \@reslt : $reslt[0];
}

sub wkt2kml { wkt2kmlparser( $_[0], []) }

my $builder;
$builder = {
    'Point' => sub {
        my $buf = 'POINT(' . join( ',', map { coordbuilder($_->{coordinates}) } @{$_[0]} ) . ')';
        $buf    = 'MULTI' . $buf if ( @{$_[0]} > 1 );
        $buf;
    },
    'LineString' => sub {
        my $buf = '(' . join( '),(', map { coordbuilder($_->{coordinates}) } @{$_[0]} ) . ')';
        $buf    = @{$_[0]} > 1 ? "MULTILINESTRING($buf)" : "LINESTRING$buf";
        $buf;
    },
    'Polygon' => sub {
        my $buf = '(' . join( '),(', map { $builder->{linearring}->($_) } @{$_[0]} ) . ')';
        $buf    = @{$_[0]} > 1 ? "MULTIPOLYGON($buf)" : "POLYGON$buf";
        $buf;
    },
    'linearring' => sub {
        my @lnr;
        push( @lnr, $_[0]->{outerBoundaryIs}->{LinearRing}->{coordinates} );
        push( @lnr, map { $_->{LinearRing}->{coordinates} } ( ref($_[0]->{innerBoundaryIs}) eq 'ARRAY' ? @{$_[0]->{innerBoundaryIs}} : ($_[0]->{innerBoundaryIs}) ) )
            if ( defined($_[0]->{innerBoundaryIs}) );
        '(' . join( '),(', map { coordbuilder($_) } @lnr ) . ')';
    },
    'MultiGeometry' => sub {
        my @key = grep { $builder->{$_} } keys %{$_[0]->[0]};
        my $buf = join( ',', map { kml2wktbuilder( $_, $_[0]->[0]->{$_} ) } @key );
        $buf    = "GEOMETRYCOLLECTION($buf)" if ( @key > 1 );
        $buf;
    },
};

sub coordbuilder {
    my $coords = $_[0];
    $coords =~ s/^[\s\n]*(.+)[\s\n]*$/$1/m;
    my @coords = split( /[\s\n]+/, $coords );
    join( ",", map { my $s = $_; $s =~ s/,/ /g; $s } @coords );
}

sub kml2wktbuilder {
    my $key = shift;
    my $arg = shift;

    if ( my $build = $builder->{$key} ) {
        my @reslt = $build->( ref($arg) eq 'ARRAY' ? $arg : [$arg]);
        return @reslt > 1 ? \@reslt : $reslt[0];
    } else {
        croak "KML $key element cannot be interpreted";
    }
}

sub kml2wkt {
    my $xml = XMLin($_[0],KeepRoot => 1);
    my ($key) = keys %{$xml};
    kml2wktbuilder( $key, $xml->{$key} );
}

1; # Magic true value required at end of module
__END__