File Coverage

blib/lib/Geo/Shapefile/Writer.pm

Criterion	Covered	Total	%
statement	122	125	97.6
branch	19	24	79.1
condition	7	11	63.6
subroutine	13	13	100.0
pod	3	3	100.0
total	164	176	93.1

package Geo::Shapefile::Writer;
{
  $Geo::Shapefile::Writer::VERSION = '0.005';
}

# $Id: Writer.pm 16 2014-07-30 08:16:24Z [e-mail] $

# NAME: Geo::Shapefile::Writer
# ABSTRACT: simple pureperl shapefile writer


use 5.010;
use strict;
use warnings;

use utf8;
use autodie;
use Carp;

use XBase;
use List::Util qw/ min max /;



my %shape_type = (
    # extend
    NULL        => 0,
    POINT       => 1,
    POLYLINE    => 3,
    POLYGON     => 5,
);



{
my @default_attr_format = ( C => 64 );

sub _get_attr_format {
    my ($format) = @_;

    my @descr = !ref $format        ? ($format)
        : ref $format eq 'ARRAY'    ? @$format
        : ref $format eq 'HASH'     ? @$format{ qw/ name type length decimals / }
                                    : ();

    croak 'Bad format description'      if !$descr[0];

    @descr[1,2] = @default_attr_format  if !$descr[1];
    return \@descr;
}
}

sub new {
    my ($class, $name, $type, @attrs) = @_;

    my $shape_type = $shape_type{ uc($type || q{}) };
    croak "Invalid shape type: $type"  if !defined $shape_type;

    my $self = bless {
        NAME     => $name,
        TYPE     => $shape_type,
        RCOUNT   => 0,
        SHP_SIZE => 50,
        SHX_SIZE => 50,
    }, $class;

    my $header_data = $self->_get_header('SHP');

    open $self->{SHP}, '>:raw', "$name.shp";
    print {$self->{SHP}} $header_data;

    open $self->{SHX}, '>:raw', "$name.shx";
    print {$self->{SHX}} $header_data;

    unlink "$name.dbf"  if -f "$name.dbf";

    my @fields = map { _get_attr_format($_) } @attrs;
    $self->{DBF} = XBase->create(
        name            => "$name.dbf",
        field_names     => [ map { $_->[0] } @fields ],
        field_types     => [ map { $_->[1] } @fields ],
        field_lengths   => [ map { $_->[2] } @fields ],
        field_decimals  => [ map { $_->[3] } @fields ],
    );

    return $self;
}


{
my $header_size = 100;
# position, pack_type, object_field, default
my @header_fields = (
    [ 0,  'N', undef,   9994 ],             # magic
    [ 24, 'N', _SIZE => $header_size / 2 ], # file size in 16-bit words
    [ 28, 'L', undef,   1000 ],             # version
    [ 32, 'L', 'TYPE' ],
    [ 36, 'd', 'XMIN' ],
    [ 44, 'd', 'YMIN' ],
    [ 52, 'd', 'XMAX' ],
    [ 60, 'd', 'YMAX' ],
);

sub _get_header {
    my ($self, $file_type) = @_;

    my @use_fields =
        grep { defined $_->[2] }
        map {[ $_->[0], $_->[1], $_->[2] && ($self->{$_->[2]} // $self->{"$file_type$_->[2]"}) // $_->[3] ]}
        @header_fields;

    my $pack_string = join q{ }, map { sprintf '@%d%s', @$_ } (@use_fields, [$header_size, q{}]);
    return pack $pack_string, map { $_->[2] } @use_fields;
}
}



sub add_shape {
    my ($self, $data, @attributes) = @_;

    my ($xmin, $ymin, $xmax, $ymax);

    my $rdata;
    my $type = $self->{TYPE};

    if ($type == $shape_type{NULL} ) {
        $rdata = pack( 'L', $self->{TYPE} );
    }
    elsif ($type == $shape_type{POINT} ) {
        $rdata = pack( 'Ldd', $self->{TYPE}, @$data );
        ($xmin, $ymin, $xmax, $ymax) = ( @$data, @$data );
    }
    elsif ($type == $shape_type{POLYLINE} || $type == $shape_type{POLYGON} ) {
        my $rpart = q{};
        my $rpoint = q{};
        my $ipoint = 0;

        for my $line ( @$data ) {
            $rpart .= pack 'L', $ipoint;
            for my $point ( @$line ) {
                my ($x, $y) = @$point;
                $rpoint .= pack 'dd', $x, $y;
                $ipoint ++;
            }
        }

        $xmin = min map {$_->[0]} map {@$_} @$data;
        $ymin = min map {$_->[1]} map {@$_} @$data;
        $xmax = max map {$_->[0]} map {@$_} @$data;
        $ymax = max map {$_->[1]} map {@$_} @$data;

        $rdata = pack 'LddddLL', $self->{TYPE}, $xmin, $ymin, $xmax, $ymax, scalar @$data, $ipoint;
        $rdata .= $rpart . $rpoint;
    }


    my $attr0 = $attributes[0];
    if ( ref $attr0 eq 'HASH' ) {
        $self->{DBF}->set_record_hash( $self->{RCOUNT}, map {( uc($_) => $attr0->{$_} )} keys %$attr0 );
    }
    elsif ( ref $attr0 eq 'ARRAY' ) {
        $self->{DBF}->set_record( $self->{RCOUNT}, @$attr0 );
    }
    else {
        $self->{DBF}->set_record( $self->{RCOUNT}, @attributes );
    }

    $self->{RCOUNT} ++;

    print {$self->{SHX}} pack 'NN', $self->{SHP_SIZE}, length($rdata)/2;
    $self->{SHX_SIZE} += 4;

    print {$self->{SHP}} pack 'NN', $self->{RCOUNT}, length($rdata)/2;
    print {$self->{SHP}} $rdata;
    $self->{SHP_SIZE} += 4+length($rdata)/2;

    $self->{XMIN} = min grep {defined} ($xmin, $self->{XMIN});
    $self->{YMIN} = min grep {defined} ($ymin, $self->{YMIN});
    $self->{XMAX} = max grep {defined} ($xmax, $self->{XMAX});
    $self->{YMAX} = max grep {defined} ($ymax, $self->{YMAX});

    return $self;
}



sub finalize {
    my $self = shift;

    my $shp = $self->{SHP};
    seek $shp, 0, 0;
    print {$shp} $self->_get_header('SHP');
    close $shp;

    my $shx = $self->{SHX};
    seek $shx, 0, 0;
    print {$shx} $self->_get_header('SHX');
    close $shx;

    $self->{DBF}->close();

    return;
}

1;

__END__