1#  tests for Geo::ShapeFile
2
3use Test::More;
4use strict;
5use warnings;
6#use rlib '../lib', './lib';
7use FindBin;
8use lib "$FindBin::Bin/lib";
9use lib "$FindBin::Bin/../lib";
10
11use Geo::ShapeFile;
12use Geo::ShapeFile::Shape;
13use Geo::ShapeFile::Point;
14
15#  should use $FindBin::bin for this
16my $dir = "t/test_data";
17
18note "Testing Geo::ShapeFile version $Geo::ShapeFile::VERSION\n";
19
20use Geo::ShapeFile::TestHelpers;
21
22#  conditional test runs approach from
23#  http://www.modernperlbooks.com/mt/2013/05/running-named-perl-tests-from-prove.html
24
25exit main( @ARGV );
26
27sub main {
28    my @args  = @_;
29
30    if (@args) {
31        for my $name (@args) {
32            die "No test method test_$name\n"
33                if not my $func = (__PACKAGE__->can( 'test_' . $name ) || __PACKAGE__->can( $name ));
34            $func->();
35        }
36        done_testing;
37        return 0;
38    }
39
40    test_open_croaks();
41    test_corners();
42    test_shapes_in_area();
43    #test_end_point_slope();
44    test_shapepoint();
45    test_files();
46    test_files_no_caching();
47    test_file_version_defined();
48    test_empty_dbf();
49    test_points_in_polygon();
50    test_spatial_index();
51    test_angle_to();
52
53    test_shape_indexing();
54
55    test_type();
56
57    done_testing;
58    return 0;
59}
60
61
62
63###########################################
64
65sub test_file_version_defined {
66    #github #22
67    my $empty_file = "$dir/empty_points";
68
69    foreach my $type (qw /shx shp/) {
70        my $obj = Geo::ShapeFile->new("${empty_file}.${type}");
71        my $version = $obj->file_version;
72
73        ok (defined $version, "file_version: got defined value for empty file of type $type");
74    }
75}
76
77
78sub test_dbf_header {
79    my %data = Geo::ShapeFile::TestHelpers::get_data();
80
81    foreach my $base (sort keys %data) {
82
83        my $shp = Geo::ShapeFile->new ("$dir/$base");
84
85        my $hdr = $shp->get_dbf_field_info;
86
87        #  not the world's best test, but it ensures the returned copy is corrct
88        is_deeply ($hdr, $shp->{dbf_field_info}, "header for $base has correct structure");
89    }
90}
91
92
93sub test_open_croaks {
94    my $filename = "blurfleblargfail";
95
96    my $shp = eval {
97        Geo::ShapeFile->new ($filename);
98    };
99    my $e = $@;
100    ok ($e, 'threw an exception on invalid file');
101
102}
103
104
105
106sub test_shapepoint {
107    my @test_points = (
108        ['1','1'],
109        ['1000000','1000000'],
110        ['9999','43525623523525'],
111        ['2532525','235253252352'],
112        ['2.1352362','1.2315216236236'],
113        ['2.2152362','1.2315231236236','1134'],
114        ['2.2312362','1.2315236136236','1214','51321'],
115        ['2.2351362','1.2315236216236','54311'],
116    );
117
118    my @pnt_objects;
119    foreach my $pts (@test_points) {
120        my ($x,$y,$m,$z) = @$pts;
121        my $txt;
122
123        if(defined $z && defined $m) {
124            $txt = "Point(X=$x,Y=$y,Z=$z,M=$m)";
125        }
126        elsif (defined $m) {
127            $txt = "Point(X=$x,Y=$y,M=$m)";
128        }
129        else {
130            $txt = "Point(X=$x,Y=$y)";
131        }
132        my $p1 = Geo::ShapeFile::Point->new(X => $x, Y => $y, Z => $z, M => $m);
133        my $p2 = Geo::ShapeFile::Point->new(Y => $y, X => $x, M => $m, Z => $z);
134        print "p1=$p1\n";
135        print "p2=$p2\n";
136        cmp_ok ( $p1, '==', $p2, "Points match");
137        cmp_ok ("$p1", 'eq', $txt);
138        cmp_ok ("$p2", 'eq', $txt);
139        push @pnt_objects, $p1;
140    }
141
142
143    return;
144
145}
146
147sub test_angle_to {
148    my $p1 = Geo::ShapeFile::Point->new (X => 0, Y => 0);
149
150    my @checks = (
151        [ 0,  0,    0],
152        [ 1,  0,   90],
153        [ 1,  1,   45],
154        [ 0,  1,    0],
155        [-1,  1,  315],
156        [-1,  0,  270],
157        [-1, -1,  225],
158        [ 0, -1,  180],
159    );
160
161    foreach my $p2_data (@checks) {
162        my ($x, $y, $exp) = @$p2_data;
163        my $p2 = Geo::ShapeFile::Point->new (X => $x, Y => $y);
164        my $angle = $p1->angle_to ($p2);
165
166        is (
167            $angle,
168            $exp,
169            "Got expected angle of $exp for $x,$y",
170        );
171    }
172
173    return;
174}
175
176sub test_end_point_slope {
177    return;  #  no testing yet - ths was used for debug
178
179    my %data  = Geo::ShapeFile::TestHelpers::get_data();
180    my %data2 = (drainage => $data{drainage});
181    %data = %data2;
182
183    my $obj = Geo::ShapeFile->new("$dir/drainage");
184    my $shape = $obj->get_shp_record(1);
185    my $start_pt = Geo::ShapeFile::Point->new(X => $shape->x_min(), Y => $shape->y_min());
186    my $end_pt   = Geo::ShapeFile::Point->new(X => $shape->x_min(), Y => $shape->y_max());
187    my $hp = $shape->has_point($start_pt);
188
189    printf
190        "%i : %i\n",
191        $shape->has_point($start_pt),
192        $shape->has_point($end_pt);
193    print;
194
195    return;
196}
197
198
199sub test_files_no_caching {
200    test_files ('no_cache');
201}
202
203sub test_files {
204    my $no_cache = shift;
205
206    my %data = Geo::ShapeFile::TestHelpers::get_data();
207
208    foreach my $base (sort keys %data) {
209        foreach my $ext (qw/dbf shp shx/) {
210            ok(-f "$dir/$base.$ext", "$ext file exists for $base");
211        }
212        my $fname = "$dir/$base.shp";
213        my $obj = $data{$base}->{object}
214                = Geo::ShapeFile->new("$dir/$base", {no_cache => $no_cache});
215
216        my @expected_fld_names
217          = grep
218            {$_ ne '_deleted'}
219            split /\s+/, $data{$base}{dbf_labels};
220        my @got_fld_names = $obj->get_dbf_field_names;
221
222        is_deeply (
223            \@expected_fld_names,
224            \@got_fld_names,
225            "got expected field names for $base",
226        );
227
228        # test SHP
229        cmp_ok (
230            $obj->shape_type_text(),
231            'eq',
232            $data{$base}->{shape_type},
233            "Shape type for $base",
234        );
235        cmp_ok(
236            $obj->shapes(),
237            '==',
238            $data{$base}->{shapes},
239            "Number of shapes for $base"
240        );
241
242        # test shapes
243        my $nulls = 0;
244        subtest "$base has valid records" => sub {
245            if (!$obj->records()) {
246                ok (1, "$base has no records, so just pass this subtest");
247            }
248
249            for my $n (1 .. $obj->shapes()) {
250                my($offset, $cl1) = $obj->get_shx_record($n);
251                my($number, $cl2) = $obj->get_shp_record_header($n);
252
253                cmp_ok($cl1, '==', $cl2,    "$base($n) shp/shx record content-lengths");
254                cmp_ok($n,   '==', $number, "$base($n) shp/shx record ids agree");
255
256                my $shp = $obj->get_shp_record($n);
257
258                if ($shp->shape_type == 0) {
259                    $nulls++;
260                }
261
262                my $parts = $shp->num_parts;
263                my @parts = $shp->parts;
264                cmp_ok($parts, '==', scalar(@parts), "$base($n) parts count");
265
266                my $points = $shp->num_points;
267                my @points = $shp->points;
268                cmp_ok($points, '==', scalar(@points), "$base($n) points count");
269
270                my $undefs = 0;
271                foreach my $pnt (@points) {
272                    defined($pnt->X) || $undefs++;
273                    defined($pnt->Y) || $undefs++;
274                }
275                ok(!$undefs, "undefined points");
276
277                my $len = length($shp->{shp_data});
278                cmp_ok($len, '==', 0, "$base($n) no leftover data");
279            }
280        };
281
282        ok($nulls == $data{$base}->{nulls});
283
284        #  need to test the bounds
285        my @shapes_in_file;
286        for my $n (1 .. $obj->shapes()) {
287            push @shapes_in_file, $obj->get_shp_record($n);
288        }
289
290        my %bounds = $obj->find_bounds(@shapes_in_file);
291        for my $bnd (qw /x_min y_min x_max y_max/) {
292            is ($bounds{$bnd}, $data{$base}{$bnd}, "$bnd across objects matches, $base");
293        }
294
295        if (defined $data{$base}{y_max}) {
296            is ($obj->height, $data{$base}{y_max} - $data{$base}{y_min}, "$base has correct height");
297            is ($obj->width,  $data{$base}{x_max} - $data{$base}{x_min}, "$base has correct width");
298        }
299        else {
300            is ($obj->height, undef, "$base has correct height");
301            is ($obj->width,  undef, "$base has correct width");
302        }
303
304        # test DBF
305        ok($obj->{dbf_version} == 3, "dbf version 3");
306
307        cmp_ok(
308            $obj->{dbf_num_records},
309            '==',
310            $obj->shapes(),
311            "$base dbf has record per shape",
312        );
313
314        cmp_ok(
315            $obj->records(),
316            '==',
317            $obj->shapes(),
318            "same number of shapes and records",
319        );
320
321        subtest "$base: can read each record" => sub {
322            if (!$obj->records()) {
323                ok (1, "$base has no records, so just pass this subtest");
324            }
325
326            for my $n (1 .. $obj->shapes()) {
327                ok (my $dbf = $obj->get_dbf_record($n), "$base($n) read dbf record");
328            }
329        };
330
331        #  This is possibly redundant due to get_dbf_field_names check above,
332        #  although that does not check against each record.
333        my @expected_flds = sort split (/ /, $data{$base}->{dbf_labels});
334        subtest "dbf for $base has correct labels" => sub {
335            if (!$obj->records()) {
336                ok (1, "$base has no records, so just pass this subtest");
337            }
338            for my $n (1 .. $obj->records()) {
339                my %record = $obj->get_dbf_record($n);
340                is_deeply (
341                    [sort keys %record],
342                    \@expected_flds,
343                    "$base, record $n",
344                );
345            }
346        };
347
348        if ($obj->shapes) {
349            #  a bit lazy, as we check for any caching, not specific caching
350            my $expect_cache = !$no_cache;
351            #  tests should not know about internals
352            my $object_cache = $obj->{_object_cache};
353            my $cache_count = 0;
354            foreach my $type (keys %$object_cache) {
355                $cache_count += scalar keys %{$object_cache->{$type}};
356            }
357            my $nc_msg = defined $no_cache ? 'on' : 'off';
358            is (!!$cache_count,
359                $expect_cache,
360                "$fname: Got expected caching for no_cache flag: $nc_msg",
361            );
362        }
363    }
364
365    return;
366}
367
368
369sub test_empty_dbf {
370    my $empty_dbf = Geo::ShapeFile::TestHelpers::get_empty_dbf();
371    my $obj = Geo::ShapeFile->new("$dir/$empty_dbf");
372    my $records = $obj->records;
373    is ($records, 0, 'empty dbf file has zero records');
374}
375
376
377sub test_shapes_in_area {
378    my $shp = Geo::ShapeFile->new ("$dir/test_shapes_in_area");
379
380    my @shapes_in_area = $shp->shapes_in_area (1, 1, 11, 11);
381    is_deeply (
382        [1],
383        \@shapes_in_area,
384        'Shape is in area'
385    );
386
387    @shapes_in_area = $shp->shapes_in_area (1, 1, 11, 9);
388    is_deeply (
389        [1],
390        \@shapes_in_area,
391        'Shape is in area'
392    );
393
394    @shapes_in_area = $shp->shapes_in_area (11, 11, 12, 12);
395    is_deeply (
396        [],
397        \@shapes_in_area,
398        'Shape is not in area'
399    );
400
401    my @bounds;
402
403    @bounds = (1, -1, 9, 11);
404    @shapes_in_area = $shp->shapes_in_area (@bounds);
405    is_deeply (
406        [1],
407        \@shapes_in_area,
408        'edge overlap on the left, right edge outside bounds',
409    );
410
411
412    @bounds = (0, -1, 9, 11);
413    @shapes_in_area = $shp->shapes_in_area (@bounds);
414    is_deeply (
415        [1],
416        \@shapes_in_area,
417        'left and right edges outside the bounds, upper and lower within',
418    );
419
420    ###  Now check with a larger region
421    $shp = Geo::ShapeFile->new("$dir/lakes");
422
423    #  This should get all features
424    @bounds = (-104, 17, -96, 22);
425    @shapes_in_area = $shp->shapes_in_area (@bounds);
426    is_deeply (
427        [1, 2, 3],
428        \@shapes_in_area,
429        'All lake shapes in bounds',
430    );
431
432    #  just the western two features
433    @bounds = (-104, 17, -100, 22);
434    @shapes_in_area = $shp->shapes_in_area (@bounds);
435    is_deeply (
436        [1, 2],
437        \@shapes_in_area,
438        'Western two lake shapes in bounds',
439    );
440
441    #  the western two features with a partial overlap
442    @bounds = (-104, 17, -101.7314, 22);
443    @shapes_in_area = $shp->shapes_in_area (@bounds);
444    is_deeply (
445        [1, 2],
446        \@shapes_in_area,
447        'Western two lake shapes in bounds, partial overlap',
448    );
449
450    return;
451}
452
453
454sub test_corners {
455    my $shp = Geo::ShapeFile->new("$dir/lakes");
456
457    my $ul = $shp->upper_left_corner();
458    my $ll = $shp->lower_left_corner();
459    my $ur = $shp->upper_right_corner();
460    my $lr = $shp->lower_right_corner();
461
462    is ($ul->X, $ll->X,'corners: min x vals');
463    is ($ur->X, $lr->X,'corners: max x vals');
464    is ($ll->Y, $lr->Y,'corners: min y vals');
465    is ($ul->Y, $ur->Y,'corners: max y vals');
466
467    cmp_ok ($ul->X, '<', $ur->X, 'corners: ul is left of ur');
468    cmp_ok ($ll->X, '<', $lr->X, 'corners: ll is left of lr');
469
470    cmp_ok ($ll->Y, '<', $ul->Y, 'corners: ll is below ul');
471    cmp_ok ($lr->Y, '<', $ur->Y, 'corners: lr is below ur');
472
473    return;
474}
475
476sub test_points_in_polygon {
477    my $shp;
478    my $filename;
479
480    #  multipart poly
481    $filename = 'states.shp';
482    $shp = Geo::ShapeFile->new ("$dir/$filename");
483
484    my @in_coords = (
485        [-112.386, 28.950],
486        [-112.341, 29.159],
487        [-112.036, 29.718],
488        [-110.186, 30.486],
489        [-114.845, 32.380],
490    );
491    my @out_coords = (
492        [-111.286, 27.395],
493        [-113.843, 30.140],
494        [-111.015, 31.767],
495        [-112.594, 34.300],
496        [-106.772, 28.420],
497        [-114.397, 24.802],
498    );
499
500    #  shape 23 is sonora
501    my $test_poly = $shp->get_shp_record(23);
502
503    subtest "$filename polygon 23 (not indexed) contains points" => sub {
504        foreach my $coord (@in_coords) {
505            my $point  = Geo::ShapeFile::Point->new(X => $coord->[0], Y => $coord->[1]);
506            my $result = $test_poly->contains_point ($point);
507            ok ($result, "$point is in $filename polygon 23");
508        }
509    };
510
511    subtest "$filename polygon 23 (not indexed) does not contain points" => sub {
512        foreach my $coord (@out_coords) {
513            my $point  = Geo::ShapeFile::Point->new(X => $coord->[0], Y => $coord->[1]);
514            my $result = $test_poly->contains_point ($point);
515            ok (!$result, "$point is not in $filename polygon 23");
516        }
517    };
518
519    #  use the spatial index
520    $test_poly->build_spatial_index;
521
522    subtest "$filename polygon 23 (indexed) contains points" => sub {
523        foreach my $coord (@in_coords) {
524            my $point  = Geo::ShapeFile::Point->new(X => $coord->[0], Y => $coord->[1]);
525            my $result = $test_poly->contains_point ($point, 0);
526            ok ($result, "$point is in $filename polygon 23 (indexed)");
527        }
528    };
529
530    subtest "$filename polygon 23 (indexed) does not contain points" => sub {
531        foreach my $coord (@out_coords) {
532            my $point  = Geo::ShapeFile::Point->new(X => $coord->[0], Y => $coord->[1]);
533            my $result = $test_poly->contains_point ($point);
534            ok (!$result, "$point is not in $filename polygon 23 (indexed)");
535        }
536    };
537
538    #  now try with a shapefile with holes in the polys
539    $filename = 'polygon.shp';
540    $shp = Geo::ShapeFile->new ("$dir/$filename");
541    #  shape 83 has holes
542    $test_poly = $shp->get_shp_record(83);
543
544    @in_coords = (
545        [477418, 4762016],
546        [476644, 4761530],
547        [477488, 4760789],
548        [477716, 4760055],
549    );
550    @out_coords = (
551        [477521, 4760247],  # hole
552        [477414, 4761150],  # hole
553        [477388, 4761419],  # hole
554        [477996, 4761648],  # hole
555        [476810, 4761766],  # outside but in bounds
556        [478214, 4760627],  # outside but in bounds
557        [477499, 4762436],  # outside bounds
558    );
559
560    subtest "$filename polygon 83 (not indexed) contains points" => sub {
561        foreach my $coord (@in_coords) {
562            my $point  = Geo::ShapeFile::Point->new(X => $coord->[0], Y => $coord->[1]);
563            my $result = $test_poly->contains_point ($point);
564            ok ($result, "$point is in $filename polygon 83");
565        }
566    };
567
568    subtest "$filename polygon 83 (not indexed) does not contain points" => sub {
569        foreach my $coord (@out_coords) {
570            my $point  = Geo::ShapeFile::Point->new(X => $coord->[0], Y => $coord->[1]);
571            my $result = $test_poly->contains_point ($point);
572            ok (!$result, "$point is not in $filename polygon 83");
573        }
574    };
575
576    #  Now with the spatial index.
577    $test_poly->build_spatial_index;
578
579    subtest "$filename polygon 83 (indexed) contains points" => sub {
580        foreach my $coord (@in_coords) {
581            my $point  = Geo::ShapeFile::Point->new(X => $coord->[0], Y => $coord->[1]);
582            my $result = $test_poly->contains_point ($point, 0);
583            ok ($result, "$point is in $filename polygon 83 (indexed)");
584        }
585    };
586    subtest "$filename polygon 83 (indexed) does not contain points" => sub {
587        foreach my $coord (@out_coords) {
588            my $point  = Geo::ShapeFile::Point->new(X => $coord->[0], Y => $coord->[1]);
589            my $result = $test_poly->contains_point ($point);
590            ok (!$result, "$point is not in $filename polygon 83 (indexed)");
591        }
592    };
593
594    return;
595}
596
597
598sub test_spatial_index {
599    #  polygon.shp has a variety of polygons
600    my $poly_file = "$dir/polygon";
601
602    my $shp_use_idx = Geo::ShapeFile->new ($poly_file);
603    my $shp_no_idx  = Geo::ShapeFile->new($poly_file);
604
605    my $sp_index = $shp_use_idx->build_spatial_index;
606
607    ok ($sp_index, 'got a spatial index');
608
609    my @bounds = $shp_use_idx->bounds;
610    my $objects = [];
611    $sp_index->query_completely_within_rect (@bounds, $objects);
612
613    my @shapes = $shp_use_idx->get_all_shapes;
614
615    is (
616        scalar @$objects,
617        scalar @shapes,
618        'index contains same number of objects as shapefile',
619    );
620
621    #  need to sort the arrays to compare them
622    my @sorted_shapes  = $shp_use_idx->get_shapes_sorted;
623    my @sorted_objects = $shp_use_idx->get_shapes_sorted ($objects);
624
625    is_deeply (
626        \@sorted_objects,
627        \@sorted_shapes,
628        'spatial_index contains all objects',
629    );
630
631    #  now get the mid-point for a lower-left bounds
632    my $mid_x =  ($bounds[0] + $bounds[2]) / 2;
633    my $mid_y =  ($bounds[1] + $bounds[3]) / 2;
634    my @bnd_ll = ($bounds[0], $bounds[1], $mid_x, $mid_y);
635
636    foreach my $expected ([\@bounds, 474], [\@bnd_ll, 130]) {
637        my $bnds = $expected->[0];
638        my $shape_count = $expected->[1];
639
640        my $shapes_in_area_no_idx  = $shp_no_idx->shapes_in_area (@$bnds);
641        my $shapes_in_area_use_idx = $shp_use_idx->shapes_in_area (@$bnds);
642
643        my $message = 'shapes_in_area same with and without spatial index, bounds: '
644            . join ' ', @$bnds;
645
646        is (scalar @$shapes_in_area_no_idx,  $shape_count, 'got right number of shapes back, no index');
647        is (scalar @$shapes_in_area_use_idx, $shape_count, 'got right number of shapes back, use index');
648
649        is_deeply (
650            [sort @$shapes_in_area_no_idx],
651            [sort @$shapes_in_area_use_idx],
652            $message,
653        );
654    }
655
656}
657
658sub test_shape_indexing {
659    my $poly_file = "$dir/poly_to_check_index";
660
661    my $shp = Geo::ShapeFile->new ($poly_file);
662
663    my @in_coords = (
664        [-1504329.017, -3384142.590],
665        [ -811568.465, -3667544.634],
666        [-1417733.948, -3793501.098],
667    );
668
669    foreach my $size (5, 10, 15, 20, 100) {
670        foreach my $shape ($shp->get_all_shapes) {
671            my %part_indexes = $shape->build_spatial_index ($size);
672            foreach my $part (values %part_indexes) {
673                my $containers = $part->{containers};
674                ok (scalar keys %$containers == $size, "index generated $size containers")
675            }
676            subtest "polygon contains points when using index of size $size" => sub {
677                foreach my $coord (@in_coords) {
678                    my $point  = Geo::ShapeFile::Point->new(X => $coord->[0], Y => $coord->[1]);
679                    my $result = $shape->contains_point ($point);
680                    ok ($result, "$point is in polygon");
681                }
682            }
683        }
684    }
685}
686
687sub test_type {
688    my $poly_file = "$dir/poly_to_check_index";
689    my $shp = Geo::ShapeFile->new ($poly_file);
690
691    ok !$shp->type_is(200), 'invalid numeric type returns false';
692    ok !$shp->type_is(5.2), 'floating point numeric type returns false';
693    ok $shp->type_is(5), 'valid numeric type returns true';
694    ok $shp->type_is('polygon'), 'valid text type returns true';
695    ok $shp->type_is('PolygoN'), 'text type is case insensitive';
696
697}
698