1 /******************************************************************************
2  *
3  * Project:  GDAL SWIG Interface declarations for Perl.
4  * Purpose:  GDAL declarations.
5  * Author:   Ari Jolma and Kevin Ruland
6  *
7  ******************************************************************************
8  * Copyright (c) 2007, Ari Jolma and Kevin Ruland
9  *
10  * Permission is hereby granted, free of charge, to any person obtaining a
11  * copy of this software and associated documentation files (the "Software"),
12  * to deal in the Software without restriction, including without limitation
13  * the rights to use, copy, modify, merge, publish, distribute, sublicense,
14  * and/or sell copies of the Software, and to permit persons to whom the
15  * Software is furnished to do so, subject to the following conditions:
16  *
17  * The above copyright notice and this permission notice shall be included
18  * in all copies or substantial portions of the Software.
19  *
20  * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
21  * OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
22  * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
23  * THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
24  * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
25  * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
26  * DEALINGS IN THE SOFTWARE.
27  *****************************************************************************/
28 
29 %include init.i
30 
31 %init %{
32   /* gdal_perl.i %init code */
33   UseExceptions();
34   if ( GDALGetDriverCount() == 0 ) {
35       GDALAllRegister();
36   }
37 %}
38 
39 %include callback.i
40 %include confess.i
41 %include cpl_exceptions.i
42 
43 %include band.i
44 
45 %rename (GetMetadata) GetMetadata_Dict;
46 %ignore GetMetadata_List;
47 
48 %import typemaps_perl.i
49 
50 %import destroy.i
51 
52 ALTERED_DESTROY(GDALColorTableShadow, GDALc, delete_ColorTable)
53 ALTERED_DESTROY(GDALConstShadow, GDALc, delete_Const)
54 ALTERED_DESTROY(GDALDatasetShadow, GDALc, delete_Dataset)
55 ALTERED_DESTROY(GDALDriverShadow, GDALc, delete_Driver)
56 ALTERED_DESTROY(GDAL_GCP, GDALc, delete_GCP)
57 ALTERED_DESTROY(GDALMajorObjectShadow, GDALc, delete_MajorObject)
58 ALTERED_DESTROY(GDALRasterAttributeTableShadow, GDALc, delete_RasterAttributeTable)
59 
60 /* remove unwanted name duplication */
61 
62 %rename (X) GCPX;
63 %rename (Y) GCPY;
64 %rename (Z) GCPZ;
65 %rename (Column) GCPPixel;
66 %rename (Row) GCPLine;
67 
68 /* Make room for Perl interface */
69 
70 %rename (_FindFile) FindFile;
71 
72 %rename (_Open) Open;
73 %newobject _Open;
74 
75 %rename (_OpenShared) OpenShared;
76 %newobject _OpenShared;
77 
78 %rename (_OpenEx) OpenEx;
79 %newobject _OpenEx;
80 
81 %rename (_BuildOverviews) BuildOverviews;
82 
83 %rename (_ReadRaster) ReadRaster;
84 %rename (_WriteRaster) WriteRaster;
85 
86 %rename (_CreateLayer) CreateLayer;
87 %rename (_DeleteLayer) DeleteLayer;
88 
89 %rename (_GetMaskFlags) GetMaskFlags;
90 %rename (_CreateMaskBand) CreateMaskBand;
91 
92 %rename (_ReprojectImage) ReprojectImage;
93 %rename (_Polygonize) Polygonize;
94 %rename (_RegenerateOverviews) RegenerateOverviews;
95 %rename (_RegenerateOverview) RegenerateOverview;
96 
97 %rename (_AutoCreateWarpedVRT) AutoCreateWarpedVRT;
98 %newobject _AutoCreateWarpedVRT;
99 
100 %rename (_Create) Create;
101 %newobject _Create;
102 
103 %rename (_CreateCopy) CreateCopy;
104 %newobject _CreateCopy;
105 
106 %rename (_GetRasterBand) GetRasterBand;
107 %rename (_AddBand) AddBand;
108 
109 %rename (_GetMaskBand) GetMaskBand;
110 %rename (_GetOverview) GetOverview;
111 
112 %rename (_GetPaletteInterpretation) GetPaletteInterpretation;
113 %rename (_GetHistogram) GetHistogram;
114 
115 %rename (_SetColorEntry) SetColorEntry;
116 
117 %rename (_GetUsageOfCol) GetUsageOfCol;
118 %rename (_GetColOfUsage) GetColOfUsage;
119 %rename (_GetTypeOfCol) GetTypeOfCol;
120 %rename (_CreateColumn) CreateColumn;
121 
122 %rename (Stat) VSIStatL;
123 
124 %perlcode %{
125 
126 package Geo::GDAL;
127 require 5.10.0; # we use //=
128 use strict;
129 use warnings;
130 use Carp;
131 use Encode;
132 use Exporter 'import';
133 use Geo::GDAL::Const;
134 
135 # $VERSION is the Perl module (CPAN) version number, which must be
136 # an increasing floating point number.  $GDAL_VERSION is the
137 # version number of the GDAL that this module is a part of. It is
138 # used in build time to check the version of GDAL against which we
139 # build.
140 # For GDAL 2.0 or above, GDAL X.Y.Z should then
141 # VERSION = X + Y / 100.0 + Z / 10000.0
142 # Note also the $VERSION in ogr_perl.i (required by pause.perl.org)
143 # Note that the 1/100000 digits may be used to create more than one
144 # CPAN release from one GDAL release.
145 
146 our $VERSION = '3.0303';
147 our $GDAL_VERSION = '3.3.3';
148 
149 =pod
150 
151 =head1 NAME
152 
153 Geo::GDAL - Perl extension for the GDAL library for geospatial data
154 
155 =head1 SYNOPSIS
156 
157   use Geo::GDAL;
158 
159   my $raster_file = shift @ARGV;
160 
161   my $raster_dataset = Geo::GDAL::Open($file);
162 
163   my $raster_data = $dataset->GetRasterBand(1)->ReadTile;
164 
165   my $vector_datasource = Geo::OGR::Open('./');
166 
167   my $vector_layer = $datasource->Layer('borders'); # e.g. a shapefile borders.shp in current directory
168 
169   $vector_layer->ResetReading();
170   while (my $feature = $vector_layer->GetNextFeature()) {
171       my $geometry = $feature->GetGeometry();
172       my $value = $feature->GetField($field);
173   }
174 
175 =head1 DESCRIPTION
176 
177 This Perl module lets you to manage (read, analyse, write) geospatial
178 data stored in several formats.
179 
180 =head2 EXPORT
181 
182 None by default.
183 
184 =head1 SEE ALSO
185 
186 The GDAL home page is L<http://gdal.org/>
187 
188 The documentation of this module is written in Doxygen format. See
189 L<http://arijolma.org/Geo-GDAL/snapshot/>
190 
191 =head1 AUTHOR
192 
193 Ari Jolma
194 
195 =head1 COPYRIGHT AND LICENSE
196 
197 Copyright (C) 2005- by Ari Jolma and GDAL bindings developers.
198 
199 This library is free software; you can redistribute it and/or modify
200 it under the terms of MIT License
201 
202 L<https://opensource.org/licenses/MIT>
203 
204 =head1 REPOSITORY
205 
206 L<https://trac.osgeo.org/gdal>
207 
208 =cut
209 
210 unless ($ENV{GDAL_PERL_BINDINGS_OK}) {
211     my $msg = "NOTE: GDAL Perl Bindings are deprecated and will be removed in version 3.5.\n";
212     $msg .= "NOTE: Please use Geo::GDAL::FFI instead.\n";
213     $msg .= "NOTE: To remove this message define environment variable GDAL_PERL_BINDINGS_OK.\n";
214     warn $msg;
215 }
216 
217 use Scalar::Util 'blessed';
218 use vars qw/
219     @EXPORT_OK %EXPORT_TAGS
220     @DATA_TYPES @OPEN_FLAGS @RESAMPLING_TYPES @RIO_RESAMPLING_TYPES @NODE_TYPES
221     %S2I %I2S @error %stdout_redirection
222     /;
223 BEGIN {
224 @EXPORT_OK = qw(
225     Driver Open BuildVRT
226     ParseXMLString NodeData Child Children NodeData ParseXMLString SerializeXMLTree
227     error last_error named_parameters keep unkeep parent note unnote make_processing_options
228     VSIStdoutSetRedirection VSIStdoutUnsetRedirection
229     i2s s2i s_exists);
230 %EXPORT_TAGS = (
231     all => [qw(Driver Open BuildVRT)],
232     XML => [qw(ParseXMLString NodeData Child Children NodeData ParseXMLString SerializeXMLTree)],
233     INTERNAL => [qw(error last_error named_parameters keep unkeep parent note unnote make_processing_options
234                     VSIStdoutSetRedirection VSIStdoutUnsetRedirection i2s s2i s_exists)]
235     );
236 }
237 *BuildVRT = *Geo::GDAL::Dataset::BuildVRT;
238 for (keys %Geo::GDAL::Const::) {
239     next if /TypeCount/;
240     push(@DATA_TYPES, $1), next if /^GDT_(\w+)/;
241     push(@OPEN_FLAGS, $1), next if /^OF_(\w+)/;
242     push(@RESAMPLING_TYPES, $1), next if /^GRA_(\w+)/;
243     push(@RIO_RESAMPLING_TYPES, $1), next if /^GRIORA_(\w+)/;
244     push(@NODE_TYPES, $1), next if /^CXT_(\w+)/;
245 }
246 for my $string (@DATA_TYPES) {
247     my $int = eval "\$Geo::GDAL::Const::GDT_$string";
248     $S2I{data_type}{$string} = $int;
249     $I2S{data_type}{$int} = $string;
250 }
251 for my $string (@OPEN_FLAGS) {
252     my $int = eval "\$Geo::GDAL::Const::OF_$string";
253     $S2I{open_flag}{$string} = $int;
254 }
255 for my $string (@RESAMPLING_TYPES) {
256     my $int = eval "\$Geo::GDAL::Const::GRA_$string";
257     $S2I{resampling}{$string} = $int;
258     $I2S{resampling}{$int} = $string;
259 }
260 for my $string (@RIO_RESAMPLING_TYPES) {
261     my $int = eval "\$Geo::GDAL::Const::GRIORA_$string";
262     $S2I{rio_resampling}{$string} = $int;
263     $I2S{rio_resampling}{$int} = $string;
264 }
265 for my $string (@NODE_TYPES) {
266     my $int = eval "\$Geo::GDAL::Const::CXT_$string";
267     $S2I{node_type}{$string} = $int;
268     $I2S{node_type}{$int} = $string;
269 }
270 
271 our $HAVE_PDL;
272 eval 'require PDL';
273 $HAVE_PDL = 1 unless $@;
274 
275 sub error {
276     if (@_) {
277         my $error;
278         if (@_ == 3) {
279             my ($ecode, $offender, $ex) = @_;
280             if ($ecode == 1) {
281                 my @k = sort keys %$ex;
282                 $error = "Unknown value: '$offender'. " if defined $offender;
283                 $error .= "Expected one of ".join(', ', @k).".";
284             } elsif ($ecode == 2) {
285                 $error = "$ex not found: '$offender'.";
286             } else {
287                 die("error in error: $ecode, $offender, $ex");
288             }
289         } else {
290             $error = shift;
291         }
292         push @error, $error;
293         $error = join("\n", reverse @error);
294         confess($error."\n");
295     }
296     my @stack = @error;
297     chomp(@stack);
298     @error = ();
299     return wantarray ? @stack : join("\n", reverse @stack);
300 }
301 
302 sub last_error {
303     my $error;
304     # all errors should be in @error
305     if (@error) {
306         $error = $error[$#error];
307     } elsif ($@) {
308         # swig exceptions are not in @error
309         $error = $@;
310         $error =~ s/ at .*//;
311     } else {
312         $error = 'unknown error';
313     }
314     chomp($error);
315     return $error;
316 }
317 
318 sub errstr {
319     my @stack = @error;
320     chomp(@stack);
321     @error = ();
322     return join("\n", @stack);
323 }
324 
325 # usage: named_parameters(\@_, key value list of default parameters);
326 # returns parameters in a hash with low-case-without-_ keys
327 sub named_parameters {
328     my $parameters = shift;
329     my %defaults = @_;
330     my %c;
331     for my $k (keys %defaults) {
332         my $c = lc($k); $c =~ s/_//g;
333         $c{$c} = $k;
334     }
335     my %named;
336     my @p = ref($parameters->[0]) eq 'HASH' ? %{$parameters->[0]} : @$parameters;
337     if (@p) {
338         my $c = lc($p[0] // ''); $c =~ s/_//g;
339         if (@p % 2 == 0 && defined $c && exists $c{$c}) {
340             for (my $i = 0; $i < @p; $i+=2) {
341                 my $c = lc($p[$i]); $c =~ s/_//g;
342                 error(1, $p[$i], \%defaults) unless defined $c{$c} && exists $defaults{$c{$c}};
343                 $named{$c} = $p[$i+1];
344             }
345         } else {
346             for (my $i = 0; $i < @p; $i++) {
347                 my $c = lc($_[$i*2]); $c =~ s/_//g;
348                 my $t = ref($defaults{$c{$c}});
349                 if (!blessed($p[$i]) and (ref($p[$i]) ne $t)) {
350                     $t = $t eq '' ? 'SCALAR' : "a reference to $t";
351                     error("parameter '$p[$i]' is not $t as it should for parameter $c{$c}.");
352                 }
353                 $named{$c} = $p[$i]; # $p[$i] could be a sub ...
354             }
355         }
356     }
357     for my $k (keys %defaults) {
358         my $c = lc($k); $c =~ s/_//g;
359         $named{$c} //= $defaults{$k};
360     }
361     return \%named;
362 }
363 
364 sub i2s {
365     my ($class, $int) = @_;
366     return $I2S{$class}{$int} if exists $I2S{$class}{$int};
367     return $int;
368 }
369 
370 sub s2i {
371     my ($class, $string, $backwards, $default) = @_;
372     $string = $default if defined $default && !defined $string;
373     return unless defined $string;
374     return $string if $backwards && exists $I2S{$class}{$string};
375     error(1, $string, $S2I{$class}) unless exists $S2I{$class}{$string};
376     $S2I{$class}{$string};
377 }
378 
379 sub s_exists {
380     my ($class, $string) = @_;
381     return exists $S2I{$class}{$string};
382 }
383 
384 sub make_processing_options {
385     my ($o) = @_;
386     my @options;
387     my $processor = sub {
388         my $val = shift;
389         if (ref $val eq 'ARRAY') {
390             return @$val;
391         } elsif (not ref $val) {
392             if ($val =~ /\s/ && $val =~ /^[+\-0-9.,% ]+$/) {
393                 return split /\s+/, $val;
394             }
395             return $val;
396         } else {
397             error("'$val' is not a valid processing option.");
398         }
399     };
400     if (ref $o eq 'HASH') {
401         for my $key (keys %$o) {
402             my $val = $o->{$key};
403             # without hyphen is deprecated
404             $key = '-'.$key unless $key =~ /^-/;
405             push @options, $key;
406             push @options, $processor->($val);
407         }
408     } elsif (ref $o eq 'ARRAY') {
409         for my $item (@$o) {
410             push @options, $processor->($item);
411         }
412     }
413     $o = \@options;
414     return $o;
415 }
416 
417 sub RELEASE_PARENT {
418 }
419 
420 sub FindFile {
421     if (@_ == 1) {
422         _FindFile('', @_);
423     } else {
424         _FindFile(@_);
425     }
426 }
427 
428 sub DataTypes {
429     return @DATA_TYPES;
430 }
431 
432 sub OpenFlags {
433     return @DATA_TYPES;
434 }
435 
436 sub ResamplingTypes {
437     return @RESAMPLING_TYPES;
438 }
439 
440 sub RIOResamplingTypes {
441     return @RIO_RESAMPLING_TYPES;
442 }
443 
444 sub NodeTypes {
445     return @NODE_TYPES;
446 }
447 
448 sub NodeType {
449     my $type = shift;
450     return i2s(node_type => $type) if $type =~ /^\d/;
451     return s2i(node_type => $type);
452 }
453 
454 sub NodeData {
455     my $node = shift;
456     return (NodeType($node->[0]), $node->[1]);
457 }
458 
459 sub Children {
460     my $node = shift;
461     return @$node[2..$#$node];
462 }
463 
464 sub Child {
465     my($node, $child) = @_;
466     return $node->[2+$child];
467 }
468 
469 sub GetDataTypeSize {
470     return _GetDataTypeSize(s2i(data_type => shift, 1));
471 }
472 
473 sub DataTypeValueRange {
474     my $t = shift;
475     s2i(data_type => $t);
476     # these values are from gdalrasterband.cpp
477     return (0,255) if $t =~ /Byte/;
478     return (0,65535) if $t =~/UInt16/;
479     return (-32768,32767) if $t =~/Int16/;
480     return (0,4294967295) if $t =~/UInt32/;
481     return (-2147483648,2147483647) if $t =~/Int32/;
482     return (-4294967295.0,4294967295.0) if $t =~/Float32/;
483     return (-4294967295.0,4294967295.0) if $t =~/Float64/;
484 }
485 
486 sub DataTypeIsComplex {
487     return _DataTypeIsComplex(s2i(data_type => shift));
488 }
489 
490 sub PackCharacter {
491     my $t = shift;
492     $t = i2s(data_type => $t);
493     s2i(data_type => $t); # test
494     my $is_big_endian = unpack("h*", pack("s", 1)) =~ /01/; # from Programming Perl
495     return 'C' if $t =~ /^Byte$/;
496     return ($is_big_endian ? 'n': 'v') if $t =~ /^UInt16$/;
497     return 's' if $t =~ /^Int16$/;
498     return ($is_big_endian ? 'N' : 'V') if $t =~ /^UInt32$/;
499     return 'l' if $t =~ /^Int32$/;
500     return 'f' if $t =~ /^Float32$/;
501     return 'd' if $t =~ /^Float64$/;
502 }
503 
504 sub GetDriverNames {
505     my @names;
506     for my $i (0..GetDriverCount()-1) {
507         my $driver = GetDriver($i);
508         push @names, $driver->Name if $driver->TestCapability('RASTER');
509     }
510     return @names;
511 }
512 *DriverNames = *GetDriverNames;
513 
514 sub Drivers {
515     my @drivers;
516     for my $i (0..GetDriverCount()-1) {
517         my $driver = GetDriver($i);
518         push @drivers, $driver if $driver->TestCapability('RASTER');
519     }
520     return @drivers;
521 }
522 
523 sub Driver {
524     return 'Geo::GDAL::Driver' unless @_;
525     my $name = shift;
526     my $driver = GetDriver($name);
527     error("Driver \"$name\" not found. Is it built in? Check with Geo::GDAL::Drivers or Geo::OGR::Drivers.")
528         unless $driver;
529     return $driver;
530 }
531 
532 sub AccessTypes {
533     return qw/ReadOnly Update/;
534 }
535 
536 sub Open {
537     my $p = named_parameters(\@_, Name => '.', Access => 'ReadOnly', Type => 'Any', Options => {}, Files => []);
538     my @flags;
539     my %o = (READONLY => 1, UPDATE => 1);
540     error(1, $p->{access}, \%o) unless $o{uc($p->{access})};
541     push @flags, uc($p->{access});
542     %o = (RASTER => 1, VECTOR => 1, ANY => 1);
543     error(1, $p->{type}, \%o) unless $o{uc($p->{type})};
544     push @flags, uc($p->{type}) unless uc($p->{type}) eq 'ANY';
545     my $dataset = OpenEx(Name => $p->{name}, Flags => \@flags, Options => $p->{options}, Files => $p->{files});
546     unless ($dataset) {
547         my $t = "Failed to open $p->{name}.";
548         $t .= " Is it a ".lc($p->{type})." dataset?" unless uc($p->{type}) eq 'ANY';
549         error($t);
550     }
551     return $dataset;
552 }
553 
554 sub OpenShared {
555     my @p = @_; # name, update
556     my @flags = qw/RASTER SHARED/;
557     $p[1] //= 'ReadOnly';
558     error(1, $p[1], {ReadOnly => 1, Update => 1}) unless ($p[1] eq 'ReadOnly' or $p[1] eq 'Update');
559     push @flags, qw/READONLY/ if $p[1] eq 'ReadOnly';
560     push @flags, qw/UPDATE/ if $p[1] eq 'Update';
561     my $dataset = OpenEx($p[0], \@flags);
562     error("Failed to open $p[0]. Is it a raster dataset?") unless $dataset;
563     return $dataset;
564 }
565 
566 sub OpenEx {
567     my $p = named_parameters(\@_, Name => '.', Flags => [], Drivers => [], Options => {}, Files => []);
568     unless ($p) {
569         my $name = shift // '';
570         my @flags = @_;
571         $p = {name => $name, flags => \@flags, drivers => [], options => {}, files => []};
572     }
573     if ($p->{flags}) {
574         my $f = 0;
575         for my $flag (@{$p->{flags}}) {
576             $f |= s2i(open_flag => $flag);
577         }
578         $p->{flags} = $f;
579     }
580     return _OpenEx($p->{name}, $p->{flags}, $p->{drivers}, $p->{options}, $p->{files});
581 }
582 
583 sub Polygonize {
584     my @params = @_;
585     $params[3] = $params[2]->GetLayerDefn->GetFieldIndex($params[3]) unless $params[3] =~ /^\d/;
586     _Polygonize(@params);
587 }
588 
589 sub RegenerateOverviews {
590     my @p = @_;
591     $p[2] = uc($p[2]) if $p[2]; # see overview.cpp:2030
592     _RegenerateOverviews(@p);
593 }
594 
595 sub RegenerateOverview {
596     my @p = @_;
597     $p[2] = uc($p[2]) if $p[2]; # see overview.cpp:2030
598     _RegenerateOverview(@p);
599 }
600 
601 sub ReprojectImage {
602     my @p = @_;
603     $p[4] = s2i(resampling => $p[4]);
604     return _ReprojectImage(@p);
605 }
606 
607 sub AutoCreateWarpedVRT {
608     my @p = @_;
609     for my $i (1..2) {
610         if (defined $p[$i] and ref($p[$i])) {
611             $p[$i] = $p[$i]->ExportToWkt;
612         }
613     }
614     $p[3] = s2i(resampling => $p[3], undef, 'NearestNeighbour');
615     return _AutoCreateWarpedVRT(@p);
616 }
617 
618 
619 
620 
621 package Geo::GDAL::MajorObject;
622 use strict;
623 use warnings;
624 use vars qw/@DOMAINS/;
625 
626 sub Domains {
627     return @DOMAINS;
628 }
629 
630 sub Description {
631     my($self, $desc) = @_;
632     SetDescription($self, $desc) if defined $desc;
633     GetDescription($self) if defined wantarray;
634 }
635 
636 sub Metadata {
637     my $self = shift,
638     my $metadata = ref $_[0] ? shift : undef;
639     my $domain = shift // '';
640     SetMetadata($self, $metadata, $domain) if defined $metadata;
641     GetMetadata($self, $domain) if defined wantarray;
642 }
643 
644 
645 
646 
647 package Geo::GDAL::Driver;
648 use strict;
649 use warnings;
650 use Carp;
651 use Scalar::Util 'blessed';
652 
653 Geo::GDAL->import(qw(:XML :INTERNAL));
654 
655 use vars qw/@CAPABILITIES @DOMAINS/;
656 for (keys %Geo::GDAL::Const::) {
657     next if /TypeCount/;
658     push(@CAPABILITIES, $1), next if /^DCAP_(\w+)/;
659 }
660 
661 sub Domains {
662     return @DOMAINS;
663 }
664 
665 sub Name {
666     my $self = shift;
667     return $self->{ShortName};
668 }
669 
670 sub Capabilities {
671     my $self = shift;
672     return @CAPABILITIES unless $self;
673     my $h = $self->GetMetadata;
674     my @cap;
675     for my $cap (@CAPABILITIES) {
676         my $test = $h->{'DCAP_'.uc($cap)};
677         push @cap, $cap if defined($test) and $test eq 'YES';
678     }
679     return @cap;
680 }
681 
682 sub TestCapability {
683     my($self, $cap) = @_;
684     my $h = $self->GetMetadata->{'DCAP_'.uc($cap)};
685     return (defined($h) and $h eq 'YES') ? 1 : undef;
686 }
687 
688 sub Extension {
689     my $self = shift;
690     my $h = $self->GetMetadata;
691     if (wantarray) {
692         my $e = $h->{DMD_EXTENSIONS};
693         my @e = split / /, $e;
694         @e = split /\//, $e if $e =~ /\//; # ILWIS returns mpr/mpl
695         for my $i (0..$#e) {
696             $e[$i] =~ s/^\.//; # CALS returns extensions with a dot prefix
697         }
698         return @e;
699     } else {
700         my $e = $h->{DMD_EXTENSION};
701         return '' if $e =~ /\//; # ILWIS returns mpr/mpl
702         $e =~ s/^\.//;
703         return $e;
704     }
705 }
706 
707 sub MIMEType {
708     my $self = shift;
709     my $h = $self->GetMetadata;
710     return $h->{DMD_MIMETYPE};
711 }
712 
713 sub CreationOptionList {
714     my $self = shift;
715     my @options;
716     my $h = $self->GetMetadata->{DMD_CREATIONOPTIONLIST};
717     if ($h) {
718         $h = ParseXMLString($h);
719         my($type, $value) = NodeData($h);
720         if ($value eq 'CreationOptionList') {
721             for my $o (Children($h)) {
722                 my %option;
723                 for my $a (Children($o)) {
724                     my(undef, $key) = NodeData($a);
725                     my(undef, $value) = NodeData(Child($a, 0));
726                     if ($key eq 'Value') {
727                         push @{$option{$key}}, $value;
728                     } else {
729                         $option{$key} = $value;
730                     }
731                 }
732                 push @options, \%option;
733             }
734         }
735     }
736     return @options;
737 }
738 
739 sub CreationDataTypes {
740     my $self = shift;
741     my $h = $self->GetMetadata;
742     return split /\s+/, $h->{DMD_CREATIONDATATYPES} if $h->{DMD_CREATIONDATATYPES};
743 }
744 
745 sub stdout_redirection_wrapper {
746     my ($self, $name, $sub, @params) = @_;
747     my $object = 0;
748     if ($name && blessed $name) {
749         $object = $name;
750         my $ref = $object->can('write');
751         VSIStdoutSetRedirection($ref);
752         $name = '/vsistdout/';
753     }
754     my $ds;
755     eval {
756         $ds = $sub->($self, $name, @params);
757     };
758     if ($object) {
759         if ($ds) {
760             $Geo::GDAL::stdout_redirection{tied(%$ds)} = $object;
761         } else {
762             VSIStdoutUnsetRedirection();
763             $object->close;
764         }
765     }
766     confess(last_error()) if $@;
767     confess("Failed. Use Geo::OGR::Driver for vector drivers.") unless $ds;
768     return $ds;
769 }
770 
771 sub Create {
772     my $self = shift;
773     my $p = named_parameters(\@_, Name => 'unnamed', Width => 256, Height => 256, Bands => 1, Type => 'Byte', Options => {});
774     my $type = s2i(data_type => $p->{type});
775     return $self->stdout_redirection_wrapper(
776         $p->{name},
777         $self->can('_Create'),
778         $p->{width}, $p->{height}, $p->{bands}, $type, $p->{options}
779     );
780 }
781 *CreateDataset = *Create;
782 
783 sub Copy {
784     my $self = shift;
785     my $p = named_parameters(\@_, Name => 'unnamed', Src => undef, Strict => 1, Options => {}, Progress => undef, ProgressData => undef);
786     return $self->stdout_redirection_wrapper(
787         $p->{name},
788         $self->can('_CreateCopy'),
789         $p->{src}, $p->{strict}, $p->{options}, $p->{progress}, $p->{progressdata});
790 }
791 *CreateCopy = *Copy;
792 
793 sub Open {
794     my $self = shift;
795     my @p = @_; # name, update
796     my @flags = qw/RASTER/;
797     push @flags, qw/READONLY/ if $p[1] eq 'ReadOnly';
798     push @flags, qw/UPDATE/ if $p[1] eq 'Update';
799     my $dataset = OpenEx($p[0], \@flags, [$self->Name()]);
800     error("Failed to open $p[0]. Is it a raster dataset?") unless $dataset;
801     return $dataset;
802 }
803 
804 
805 
806 
807 package Geo::GDAL::Dataset;
808 use strict;
809 use warnings;
810 use POSIX qw/floor ceil/;
811 use Scalar::Util 'blessed';
812 use Carp;
813 use Exporter 'import';
814 
815 Geo::GDAL->import(qw(:INTERNAL));
816 
817 use vars qw/@EXPORT @DOMAINS @CAPABILITIES %CAPABILITIES/;
818 
819 @EXPORT = qw/BuildVRT/;
820 @DOMAINS = qw/IMAGE_STRUCTURE SUBDATASETS GEOLOCATION/;
821 
822 sub RELEASE_PARENT {
823     my $self = shift;
824     unkeep($self);
825 }
826 
827 *Driver = *GetDriver;
828 
829 sub Dataset {
830     my $self = shift;
831     parent($self);
832 }
833 
834 sub Domains {
835     return @DOMAINS;
836 }
837 
838 *Open = *Geo::GDAL::Open;
839 *OpenShared = *Geo::GDAL::OpenShared;
840 
841 sub TestCapability {
842     return _TestCapability(@_);
843 }
844 
845 sub Size {
846     my $self = shift;
847     return ($self->{RasterXSize}, $self->{RasterYSize});
848 }
849 
850 sub Bands {
851     my $self = shift;
852     my @bands;
853     for my $i (1..$self->{RasterCount}) {
854         push @bands, GetRasterBand($self, $i);
855     }
856     return @bands;
857 }
858 
859 sub GetRasterBand {
860     my ($self, $index) = @_;
861     $index //= 1;
862     my $band = _GetRasterBand($self, $index);
863     error(2, $index, 'Band') unless $band;
864     keep($band, $self);
865 }
866 *Band = *GetRasterBand;
867 
868 sub AddBand {
869     my ($self, $type, $options) = @_;
870     $type //= 'Byte';
871     $type = s2i(data_type => $type);
872     $self->_AddBand($type, $options);
873     return unless defined wantarray;
874     return $self->GetRasterBand($self->{RasterCount});
875 }
876 
877 sub CreateMaskBand {
878     return _CreateMaskBand(@_);
879 }
880 
881 sub ExecuteSQL {
882     my $self = shift;
883     my $layer = $self->_ExecuteSQL(@_);
884     note($layer, "is result set");
885     keep($layer, $self);
886 }
887 
888 sub ReleaseResultSet {
889     # a no-op, _ReleaseResultSet is called from Layer::DESTROY
890 }
891 
892 sub GetLayer {
893     my($self, $name) = @_;
894     my $layer = defined $name ? GetLayerByName($self, "$name") : GetLayerByIndex($self, 0);
895     $name //= '';
896     error(2, $name, 'Layer') unless $layer;
897     keep($layer, $self);
898 }
899 *Layer = *GetLayer;
900 
901 sub GetLayerNames {
902     my $self = shift;
903     my @names;
904     for my $i (0..$self->GetLayerCount-1) {
905         my $layer = GetLayerByIndex($self, $i);
906         push @names, $layer->GetName;
907     }
908     return @names;
909 }
910 *Layers = *GetLayerNames;
911 
912 sub CreateLayer {
913     my $self = shift;
914     my $p = named_parameters(\@_,
915                              Name => 'unnamed',
916                              SRS => undef,
917                              GeometryType => 'Unknown',
918                              Options => {},
919                              Schema => undef,
920                              Fields => undef,
921                              ApproxOK => 1);
922     error("The 'Fields' argument must be an array reference.") if $p->{fields} && ref($p->{fields}) ne 'ARRAY';
923     if (defined $p->{schema}) {
924         my $s = $p->{schema};
925         $p->{geometrytype} = $s->{GeometryType} if exists $s->{GeometryType};
926         $p->{fields} = $s->{Fields} if exists $s->{Fields};
927         $p->{name} = $s->{Name} if exists $s->{Name};
928     }
929     $p->{fields} = [] unless ref($p->{fields}) eq 'ARRAY';
930     # if fields contains spatial fields, then do not create default one
931     for my $f (@{$p->{fields}}) {
932         error("Field definitions must be hash references.") unless ref $f eq 'HASH';
933         if ($f->{GeometryType} || ($f->{Type} && s_exists(geometry_type => $f->{Type}))) {
934             $p->{geometrytype} = 'None';
935             last;
936         }
937     }
938     my $gt = s2i(geometry_type => $p->{geometrytype});
939     my $layer = _CreateLayer($self, $p->{name}, $p->{srs}, $gt, $p->{options});
940     for my $f (@{$p->{fields}}) {
941         $layer->CreateField($f);
942     }
943     keep($layer, $self);
944 }
945 
946 sub DeleteLayer {
947     my ($self, $name) = @_;
948     my $index;
949     for my $i (0..$self->GetLayerCount-1) {
950         my $layer = GetLayerByIndex($self, $i);
951         $index = $i, last if $layer->GetName eq $name;
952     }
953     error(2, $name, 'Layer') unless defined $index;
954     _DeleteLayer($self, $index);
955 }
956 
957 sub Projection {
958     my($self, $proj) = @_;
959     SetProjection($self, $proj) if defined $proj;
960     GetProjection($self) if defined wantarray;
961 }
962 
963 sub SpatialReference {
964     my($self, $sr) = @_;
965     SetProjection($self, $sr->As('WKT')) if defined $sr;
966     if (defined wantarray) {
967         my $p = GetProjection($self);
968         return unless $p;
969         return Geo::OSR::SpatialReference->new(WKT => $p);
970     }
971 }
972 
973 sub GeoTransform {
974     my $self = shift;
975     eval {
976         if (@_ == 1) {
977             SetGeoTransform($self, $_[0]);
978         } elsif (@_ > 1) {
979             SetGeoTransform($self, \@_);
980         }
981     };
982     confess(last_error()) if $@;
983     return unless defined wantarray;
984     my $t = GetGeoTransform($self);
985     if (wantarray) {
986         return @$t;
987     } else {
988         return Geo::GDAL::GeoTransform->new($t);
989     }
990 }
991 
992 sub Extent {
993     my $self = shift;
994     my $t = $self->GeoTransform;
995     my $extent = $t->Extent($self->Size);
996     if (@_) {
997         my ($xoff, $yoff, $w, $h) = @_;
998         my ($x, $y) = $t->Apply([$xoff, $xoff+$w, $xoff+$w, $xoff], [$yoff, $yoff, $yoff+$h, $yoff+$h]);
999         my $xmin = shift @$x;
1000         my $xmax = $xmin;
1001         for my $x (@$x) {
1002             $xmin = $x if $x < $xmin;
1003             $xmax = $x if $x > $xmax;
1004         }
1005         my $ymin = shift @$y;
1006         my $ymax = $ymin;
1007         for my $y (@$y) {
1008             $ymin = $y if $y < $ymin;
1009             $ymax = $y if $y > $ymax;
1010         }
1011         $extent = Geo::GDAL::Extent->new($xmin, $ymin, $xmax, $ymax);
1012     }
1013     return $extent;
1014 }
1015 
1016 sub Tile { # $xoff, $yoff, $xsize, $ysize, assuming strict north up
1017     my ($self, $e) = @_;
1018     my ($w, $h) = $self->Size;
1019     my $t = $self->GeoTransform;
1020     confess "GeoTransform is not \"north up\"." unless $t->NorthUp;
1021     my $xoff = floor(($e->[0] - $t->[0])/$t->[1]);
1022     $xoff = 0 if $xoff < 0;
1023     my $yoff = floor(($e->[1] - $t->[3])/$t->[5]);
1024     $yoff = 0 if $yoff < 0;
1025     my $xsize = ceil(($e->[2] - $t->[0])/$t->[1]) - $xoff;
1026     $xsize = $w - $xoff if $xsize > $w - $xoff;
1027     my $ysize = ceil(($e->[3] - $t->[3])/$t->[5]) - $yoff;
1028     $ysize = $h - $yoff if $ysize > $h - $yoff;
1029     return ($xoff, $yoff, $xsize, $ysize);
1030 }
1031 
1032 sub GCPs {
1033     my $self = shift;
1034     if (@_ > 0) {
1035         my $proj = pop @_;
1036         $proj = $proj->Export('WKT') if $proj and ref($proj);
1037         SetGCPs($self, \@_, $proj);
1038     }
1039     return unless defined wantarray;
1040     my $proj = Geo::OSR::SpatialReference->new(GetGCPProjection($self));
1041     my $GCPs = GetGCPs($self);
1042     return (@$GCPs, $proj);
1043 }
1044 
1045 sub ReadTile {
1046     my ($self, $xoff, $yoff, $xsize, $ysize, $w_tile, $h_tile, $alg) = @_;
1047     my @data;
1048     for my $i (0..$self->Bands-1) {
1049         $data[$i] = $self->Band($i+1)->ReadTile($xoff, $yoff, $xsize, $ysize, $w_tile, $h_tile, $alg);
1050     }
1051     return \@data;
1052 }
1053 
1054 sub WriteTile {
1055     my ($self, $data, $xoff, $yoff) = @_;
1056     $xoff //= 0;
1057     $yoff //= 0;
1058     for my $i (0..$self->Bands-1) {
1059         $self->Band($i+1)->WriteTile($data->[$i], $xoff, $yoff);
1060     }
1061 }
1062 
1063 sub ReadRaster {
1064     my $self = shift;
1065     my ($width, $height) = $self->Size;
1066     my ($type) = $self->Band->DataType;
1067     my $p = named_parameters(\@_,
1068                              XOff => 0,
1069                              YOff => 0,
1070                              XSize => $width,
1071                              YSize => $height,
1072                              BufXSize => undef,
1073                              BufYSize => undef,
1074                              BufType => $type,
1075                              BandList => [1],
1076                              BufPixelSpace => 0,
1077                              BufLineSpace => 0,
1078                              BufBandSpace => 0,
1079                              ResampleAlg => 'NearestNeighbour',
1080                              Progress => undef,
1081                              ProgressData => undef
1082         );
1083     $p->{resamplealg} = s2i(rio_resampling => $p->{resamplealg});
1084     $p->{buftype} = s2i(data_type => $p->{buftype}, 1);
1085     $self->_ReadRaster($p->{xoff},$p->{yoff},$p->{xsize},$p->{ysize},$p->{bufxsize},$p->{bufysize},$p->{buftype},$p->{bandlist},$p->{bufpixelspace},$p->{buflinespace},$p->{bufbandspace},$p->{resamplealg},$p->{progress},$p->{progressdata});
1086 }
1087 
1088 sub WriteRaster {
1089     my $self = shift;
1090     my ($width, $height) = $self->Size;
1091     my ($type) = $self->Band->DataType;
1092     my $p = named_parameters(\@_,
1093                              XOff => 0,
1094                              YOff => 0,
1095                              XSize => $width,
1096                              YSize => $height,
1097                              Buf => undef,
1098                              BufXSize => undef,
1099                              BufYSize => undef,
1100                              BufType => $type,
1101                              BandList => [1],
1102                              BufPixelSpace => 0,
1103                              BufLineSpace => 0,
1104                              BufBandSpace => 0
1105         );
1106     $p->{buftype} = s2i(data_type => $p->{buftype}, 1);
1107     $self->_WriteRaster($p->{xoff},$p->{yoff},$p->{xsize},$p->{ysize},$p->{buf},$p->{bufxsize},$p->{bufysize},$p->{buftype},$p->{bandlist},$p->{bufpixelspace},$p->{buflinespace},$p->{bufbandspace});
1108 }
1109 
1110 sub BuildOverviews {
1111     my $self = shift;
1112     my @p = @_;
1113     $p[0] = uc($p[0]) if $p[0];
1114     eval {
1115         $self->_BuildOverviews(@p);
1116     };
1117     confess(last_error()) if $@;
1118 }
1119 
1120 sub stdout_redirection_wrapper {
1121     my ($self, $name, $sub, @params) = @_;
1122     my $object = 0;
1123     if ($name && blessed $name) {
1124         $object = $name;
1125         my $ref = $object->can('write');
1126         VSIStdoutSetRedirection($ref);
1127         $name = '/vsistdout/';
1128     }
1129     my $ds;
1130     eval {
1131         $ds = $sub->($name, $self, @params); # self and name opposite to what is in Geo::GDAL::Driver!
1132     };
1133     if ($object) {
1134         if ($ds) {
1135             $Geo::GDAL::stdout_redirection{tied(%$ds)} = $object;
1136         } else {
1137             VSIStdoutUnsetRedirection();
1138             $object->close;
1139         }
1140     }
1141     confess(last_error()) if $@;
1142     return $ds;
1143 }
1144 
1145 sub DEMProcessing {
1146     my ($self, $dest, $Processing, $ColorFilename, $options, $progress, $progress_data) = @_;
1147     $options = Geo::GDAL::GDALDEMProcessingOptions->new(make_processing_options($options));
1148     return $self->stdout_redirection_wrapper(
1149         $dest,
1150         \&Geo::GDAL::wrapper_GDALDEMProcessing,
1151         $Processing, $ColorFilename, $options, $progress, $progress_data
1152     );
1153 }
1154 
1155 sub Nearblack {
1156     my ($self, $dest, $options, $progress, $progress_data) = @_;
1157     $options = Geo::GDAL::GDALNearblackOptions->new(make_processing_options($options));
1158     my $b = blessed($dest);
1159     if ($b && $b eq 'Geo::GDAL::Dataset') {
1160         Geo::GDAL::wrapper_GDALNearblackDestDS($dest, $self, $options, $progress, $progress_data);
1161     } else {
1162         return $self->stdout_redirection_wrapper(
1163             $dest,
1164             \&Geo::GDAL::wrapper_GDALNearblackDestName,
1165             $options, $progress, $progress_data
1166         );
1167     }
1168 }
1169 
1170 sub Translate {
1171     my ($self, $dest, $options, $progress, $progress_data) = @_;
1172     return $self->stdout_redirection_wrapper(
1173         $dest,
1174         sub {
1175             my ($dest, $self) = @_;
1176             my $ds;
1177             if ($self->_GetRasterBand(1)) {
1178                 $options = Geo::GDAL::GDALTranslateOptions->new(make_processing_options($options));
1179                 $ds = Geo::GDAL::wrapper_GDALTranslate($dest, $self, $options, $progress, $progress_data);
1180             } else {
1181                 $options = Geo::GDAL::GDALVectorTranslateOptions->new(make_processing_options($options));
1182                 Geo::GDAL::wrapper_GDALVectorTranslateDestDS($dest, $self, $options, $progress, $progress_data);
1183                 $ds = Geo::GDAL::wrapper_GDALVectorTranslateDestName($dest, $self, $options, $progress, $progress_data);
1184             }
1185             return $ds;
1186         }
1187     );
1188 }
1189 
1190 sub Warped {
1191     my $self = shift;
1192     my $p = named_parameters(\@_, SrcSRS => undef, DstSRS => undef, ResampleAlg => 'NearestNeighbour', MaxError => 0);
1193     for my $srs (qw/srcsrs dstsrs/) {
1194         $p->{$srs} = $p->{$srs}->ExportToWkt if $p->{$srs} && blessed $p->{$srs};
1195     }
1196     $p->{resamplealg} = s2i(resampling => $p->{resamplealg});
1197     my $warped = Geo::GDAL::_AutoCreateWarpedVRT($self, $p->{srcsrs}, $p->{dstsrs}, $p->{resamplealg}, $p->{maxerror});
1198     keep($warped, $self) if $warped; # self must live as long as warped
1199 }
1200 
1201 sub Warp {
1202     my ($self, $dest, $options, $progress, $progress_data) = @_;
1203     # can be run as object method (one dataset) and as package sub (a list of datasets)
1204     $options = Geo::GDAL::GDALWarpAppOptions->new(make_processing_options($options));
1205     my $b = blessed($dest);
1206     $self = [$self] unless ref $self eq 'ARRAY';
1207     if ($b && $b eq 'Geo::GDAL::Dataset') {
1208         Geo::GDAL::wrapper_GDALWarpDestDS($dest, $self, $options, $progress, $progress_data);
1209     } else {
1210         return stdout_redirection_wrapper(
1211             $self,
1212             $dest,
1213             \&Geo::GDAL::wrapper_GDALWarpDestName,
1214             $options, $progress, $progress_data
1215         );
1216     }
1217 }
1218 
1219 sub Info {
1220     my ($self, $o) = @_;
1221     $o = Geo::GDAL::GDALInfoOptions->new(make_processing_options($o));
1222     return GDALInfo($self, $o);
1223 }
1224 
1225 sub Grid {
1226     my ($self, $dest, $options, $progress, $progress_data) = @_;
1227     $options = Geo::GDAL::GDALGridOptions->new(make_processing_options($options));
1228     return $self->stdout_redirection_wrapper(
1229         $dest,
1230         \&Geo::GDAL::wrapper_GDALGrid,
1231         $options, $progress, $progress_data
1232     );
1233 }
1234 
1235 sub Rasterize {
1236     my ($self, $dest, $options, $progress, $progress_data) = @_;
1237     $options = Geo::GDAL::GDALRasterizeOptions->new(make_processing_options($options));
1238     my $b = blessed($dest);
1239     if ($b && $b eq 'Geo::GDAL::Dataset') {
1240         Geo::GDAL::wrapper_GDALRasterizeDestDS($dest, $self, $options, $progress, $progress_data);
1241     } else {
1242         # TODO: options need to force a new raster be made, otherwise segfault
1243         return $self->stdout_redirection_wrapper(
1244             $dest,
1245             \&Geo::GDAL::wrapper_GDALRasterizeDestName,
1246             $options, $progress, $progress_data
1247         );
1248     }
1249 }
1250 
1251 sub BuildVRT {
1252     my ($dest, $sources, $options, $progress, $progress_data) = @_;
1253     $options = Geo::GDAL::GDALBuildVRTOptions->new(make_processing_options($options));
1254     error("Usage: Geo::GDAL::DataSet::BuildVRT(\$vrt_file_name, \\\@sources)")
1255         unless ref $sources eq 'ARRAY' && defined $sources->[0];
1256     unless (blessed($dest)) {
1257         if (blessed($sources->[0])) {
1258             return Geo::GDAL::wrapper_GDALBuildVRT_objects($dest, $sources, $options, $progress, $progress_data);
1259         } else {
1260             return Geo::GDAL::wrapper_GDALBuildVRT_names($dest, $sources, $options, $progress, $progress_data);
1261         }
1262     } else {
1263         if (blessed($sources->[0])) {
1264             return stdout_redirection_wrapper(
1265                 $sources, $dest,
1266                 \&Geo::GDAL::wrapper_GDALBuildVRT_objects,
1267                 $options, $progress, $progress_data);
1268         } else {
1269             return stdout_redirection_wrapper(
1270                 $sources, $dest,
1271                 \&Geo::GDAL::wrapper_GDALBuildVRT_names,
1272                 $options, $progress, $progress_data);
1273         }
1274     }
1275 }
1276 
1277 sub ComputeColorTable {
1278     my $self = shift;
1279     my $p = named_parameters(\@_,
1280                              Red => undef,
1281                              Green => undef,
1282                              Blue => undef,
1283                              NumColors => 256,
1284                              Progress => undef,
1285                              ProgressData => undef,
1286                              Method => 'MedianCut');
1287     for my $b ($self->Bands) {
1288         for my $cion ($b->ColorInterpretation) {
1289             if ($cion eq 'RedBand') { $p->{red} //= $b; last; }
1290             if ($cion eq 'GreenBand') { $p->{green} //= $b; last; }
1291             if ($cion eq 'BlueBand') { $p->{blue} //= $b; last; }
1292         }
1293     }
1294     my $ct = Geo::GDAL::ColorTable->new;
1295     Geo::GDAL::ComputeMedianCutPCT($p->{red},
1296                                    $p->{green},
1297                                    $p->{blue},
1298                                    $p->{numcolors},
1299                                    $ct, $p->{progress},
1300                                    $p->{progressdata});
1301     return $ct;
1302 }
1303 
1304 sub Dither {
1305     my $self = shift;
1306     my $p = named_parameters(\@_,
1307                              Red => undef,
1308                              Green => undef,
1309                              Blue => undef,
1310                              Dest => undef,
1311                              ColorTable => undef,
1312                              Progress => undef,
1313                              ProgressData => undef);
1314     for my $b ($self->Bands) {
1315         for my $cion ($b->ColorInterpretation) {
1316             if ($cion eq 'RedBand') { $p->{red} //= $b; last; }
1317             if ($cion eq 'GreenBand') { $p->{green} //= $b; last; }
1318             if ($cion eq 'BlueBand') { $p->{blue} //= $b; last; }
1319         }
1320     }
1321     my ($w, $h) = $self->Size;
1322     $p->{dest} //= Geo::GDAL::Driver('MEM')->Create(Name => 'dithered',
1323                                                     Width => $w,
1324                                                     Height => $h,
1325                                                     Type => 'Byte')->Band;
1326     $p->{colortable}
1327         //= $p->{dest}->ColorTable
1328             // $self->ComputeColorTable(Red => $p->{red},
1329                                         Green => $p->{green},
1330                                         Blue => $p->{blue},
1331                                         Progress => $p->{progress},
1332                                         ProgressData => $p->{progressdata});
1333     Geo::GDAL::DitherRGB2PCT($p->{red},
1334                              $p->{green},
1335                              $p->{blue},
1336                              $p->{dest},
1337                              $p->{colortable},
1338                              $p->{progress},
1339                              $p->{progressdata});
1340     $p->{dest}->ColorTable($p->{colortable});
1341     return $p->{dest};
1342 }
1343 
1344 
1345 
1346 
1347 package Geo::GDAL::Band;
1348 use strict;
1349 use warnings;
1350 use POSIX;
1351 use Carp;
1352 use Scalar::Util 'blessed';
1353 
1354 Geo::GDAL->import(qw(:INTERNAL));
1355 
1356 use vars qw/
1357     @COLOR_INTERPRETATIONS @DOMAINS
1358     %MASK_FLAGS %DATATYPE2PDL %PDL2DATATYPE
1359     /;
1360 
1361 for (keys %Geo::GDAL::Const::) {
1362     next if /TypeCount/;
1363     push(@COLOR_INTERPRETATIONS, $1), next if /^GCI_(\w+)/;
1364 }
1365 for my $string (@COLOR_INTERPRETATIONS) {
1366     my $int = eval "\$Geo::GDAL::Constc::GCI_$string";
1367     $Geo::GDAL::S2I{color_interpretation}{$string} = $int;
1368     $Geo::GDAL::I2S{color_interpretation}{$int} = $string;
1369 }
1370 @DOMAINS = qw/IMAGE_STRUCTURE RESAMPLING/;
1371 %MASK_FLAGS = (AllValid => 1, PerDataset => 2, Alpha => 4, NoData => 8);
1372 if ($Geo::GDAL::HAVE_PDL) {
1373     require PDL;
1374     require PDL::Types;
1375     %DATATYPE2PDL = (
1376         $Geo::GDAL::Const::GDT_Byte => $PDL::Types::PDL_B,
1377         $Geo::GDAL::Const::GDT_Int16 => $PDL::Types::PDL_S,
1378         $Geo::GDAL::Const::GDT_UInt16 => $PDL::Types::PDL_US,
1379         $Geo::GDAL::Const::GDT_Int32 => $PDL::Types::PDL_L,
1380         $Geo::GDAL::Const::GDT_UInt32 => -1,
1381         #$PDL_IND,
1382         #$PDL_LL,
1383         $Geo::GDAL::Const::GDT_Float32 => $PDL::Types::PDL_F,
1384         $Geo::GDAL::Const::GDT_Float64 => $PDL::Types::PDL_D,
1385         $Geo::GDAL::Const::GDT_CInt16 => -1,
1386         $Geo::GDAL::Const::GDT_CInt32 => -1,
1387         $Geo::GDAL::Const::GDT_CFloat32 => -1,
1388         $Geo::GDAL::Const::GDT_CFloat64 => -1
1389         );
1390     %PDL2DATATYPE = (
1391         $PDL::Types::PDL_B => $Geo::GDAL::Const::GDT_Byte,
1392         $PDL::Types::PDL_S => $Geo::GDAL::Const::GDT_Int16,
1393         $PDL::Types::PDL_US => $Geo::GDAL::Const::GDT_UInt16,
1394         $PDL::Types::PDL_L  => $Geo::GDAL::Const::GDT_Int32,
1395         $PDL::Types::PDL_IND  => -1,
1396         $PDL::Types::PDL_LL  => -1,
1397         $PDL::Types::PDL_F  => $Geo::GDAL::Const::GDT_Float32,
1398         $PDL::Types::PDL_D => $Geo::GDAL::Const::GDT_Float64
1399         );
1400 }
1401 
1402 sub Domains {
1403     return @DOMAINS;
1404 }
1405 
1406 sub ColorInterpretations {
1407     return @COLOR_INTERPRETATIONS;
1408 }
1409 
1410 sub MaskFlags {
1411     my @f = sort {$MASK_FLAGS{$a} <=> $MASK_FLAGS{$b}} keys %MASK_FLAGS;
1412     return @f;
1413 }
1414 
1415 sub DESTROY {
1416     my $self = shift;
1417     unless ($self->isa('SCALAR')) {
1418         return unless $self->isa('HASH');
1419         $self = tied(%{$self});
1420         return unless defined $self;
1421     }
1422     delete $ITERATORS{$self};
1423     if (exists $OWNER{$self}) {
1424         delete $OWNER{$self};
1425     }
1426     $self->RELEASE_PARENT;
1427 }
1428 
1429 sub RELEASE_PARENT {
1430     my $self = shift;
1431     unkeep($self);
1432 }
1433 
1434 sub Dataset {
1435     my $self = shift;
1436     parent($self);
1437 }
1438 
1439 sub Size {
1440     my $self = shift;
1441     return ($self->{XSize}, $self->{YSize});
1442 }
1443 *BlockSize = *GetBlockSize;
1444 
1445 sub DataType {
1446     my $self = shift;
1447     return i2s(data_type => $self->{DataType});
1448 }
1449 
1450 sub PackCharacter {
1451     my $self = shift;
1452     return Geo::GDAL::PackCharacter($self->DataType);
1453 }
1454 
1455 sub NoDataValue {
1456     my $self = shift;
1457     if (@_ > 0) {
1458         if (defined $_[0]) {
1459             SetNoDataValue($self, $_[0]);
1460         } else {
1461             SetNoDataValue($self, POSIX::FLT_MAX); # hopefully an "out of range" value
1462         }
1463     }
1464     GetNoDataValue($self);
1465 }
1466 
1467 sub Unit {
1468     my $self = shift;
1469     if (@_ > 0) {
1470         my $unit = shift;
1471         $unit //= '';
1472         SetUnitType($self, $unit);
1473     }
1474     return unless defined wantarray;
1475     GetUnitType($self);
1476 }
1477 
1478 sub ScaleAndOffset {
1479     my $self = shift;
1480     SetScale($self, $_[0]) if @_ > 0 and defined $_[0];
1481     SetOffset($self, $_[1]) if @_ > 1 and defined $_[1];
1482     return unless defined wantarray;
1483     my $scale = GetScale($self);
1484     my $offset = GetOffset($self);
1485     return ($scale, $offset);
1486 }
1487 
1488 sub ReadTile {
1489     my($self, $xoff, $yoff, $xsize, $ysize, $w_tile, $h_tile, $alg) = @_;
1490     $xoff //= 0;
1491     $yoff //= 0;
1492     $xsize //= $self->{XSize} - $xoff;
1493     $ysize //= $self->{YSize} - $yoff;
1494     $w_tile //= $xsize;
1495     $h_tile //= $ysize;
1496     $alg //= 'NearestNeighbour';
1497     $alg = s2i(rio_resampling => $alg);
1498     my $t = $self->{DataType};
1499     my $buf = $self->_ReadRaster($xoff, $yoff, $xsize, $ysize, $w_tile, $h_tile, $t, 0, 0, $alg);
1500     my $pc = Geo::GDAL::PackCharacter($t);
1501     my $w = $w_tile * Geo::GDAL::GetDataTypeSize($t)/8;
1502     my $offset = 0;
1503     my @data;
1504     for my $y (0..$h_tile-1) {
1505         my @d = unpack($pc."[$w_tile]", substr($buf, $offset, $w));
1506         push @data, \@d;
1507         $offset += $w;
1508     }
1509     return \@data;
1510 }
1511 
1512 sub WriteTile {
1513     my($self, $data, $xoff, $yoff) = @_;
1514     $xoff //= 0;
1515     $yoff //= 0;
1516     error('The data must be in a two-dimensional array') unless ref $data eq 'ARRAY' && ref $data->[0] eq 'ARRAY';
1517     my $xsize = @{$data->[0]};
1518     if ($xsize > $self->{XSize} - $xoff) {
1519         warn "Buffer XSize too large ($xsize) for this raster band (width = $self->{XSize}, offset = $xoff).";
1520         $xsize = $self->{XSize} - $xoff;
1521     }
1522     my $ysize = @{$data};
1523     if ($ysize > $self->{YSize} - $yoff) {
1524         $ysize = $self->{YSize} - $yoff;
1525         warn "Buffer YSize too large ($ysize) for this raster band (height = $self->{YSize}, offset = $yoff).";
1526     }
1527     my $pc = Geo::GDAL::PackCharacter($self->{DataType});
1528     for my $i (0..$ysize-1) {
1529         my $scanline = pack($pc."[$xsize]", @{$data->[$i]});
1530         $self->WriteRaster( $xoff, $yoff+$i, $xsize, 1, $scanline );
1531     }
1532 }
1533 
1534 sub ColorInterpretation {
1535     my($self, $ci) = @_;
1536     if (defined $ci) {
1537         $ci = s2i(color_interpretation => $ci);
1538         SetRasterColorInterpretation($self, $ci);
1539     }
1540     return unless defined wantarray;
1541     i2s(color_interpretation => GetRasterColorInterpretation($self));
1542 }
1543 
1544 sub ColorTable {
1545     my $self = shift;
1546     SetRasterColorTable($self, $_[0]) if @_ and defined $_[0];
1547     return unless defined wantarray;
1548     GetRasterColorTable($self);
1549 }
1550 
1551 sub CategoryNames {
1552     my $self = shift;
1553     SetRasterCategoryNames($self, \@_) if @_;
1554     return unless defined wantarray;
1555     my $n = GetRasterCategoryNames($self);
1556     return @$n;
1557 }
1558 
1559 sub AttributeTable {
1560     my $self = shift;
1561     SetDefaultRAT($self, $_[0]) if @_ and defined $_[0];
1562     return unless defined wantarray;
1563     my $r = GetDefaultRAT($self);
1564     keep($r, $self) if $r;
1565 }
1566 *RasterAttributeTable = *AttributeTable;
1567 
1568 sub GetHistogram {
1569     my $self = shift;
1570     my $p = named_parameters(\@_,
1571                              Min => -0.5,
1572                              Max => 255.5,
1573                              Buckets => 256,
1574                              IncludeOutOfRange => 0,
1575                              ApproxOK => 0,
1576                              Progress => undef,
1577                              ProgressData => undef);
1578     $p->{progressdata} = 1 if $p->{progress} and not defined $p->{progressdata};
1579     _GetHistogram($self, $p->{min}, $p->{max}, $p->{buckets},
1580                   $p->{includeoutofrange}, $p->{approxok},
1581                   $p->{progress}, $p->{progressdata});
1582 }
1583 
1584 sub Contours {
1585     my $self = shift;
1586     my $p = named_parameters(\@_,
1587                              DataSource => undef,
1588                              LayerConstructor => {Name => 'contours'},
1589                              ContourInterval => 100,
1590                              ContourBase => 0,
1591                              FixedLevels => [],
1592                              NoDataValue => undef,
1593                              IDField => -1,
1594                              ElevField => -1,
1595                              Progress => undef,
1596                              ProgressData => undef);
1597     $p->{datasource} //= Geo::OGR::GetDriver('Memory')->CreateDataSource('ds');
1598     $p->{layerconstructor}->{Schema} //= {};
1599     $p->{layerconstructor}->{Schema}{Fields} //= [];
1600     my %fields;
1601     unless ($p->{idfield} =~ /^[+-]?\d+$/ or $fields{$p->{idfield}}) {
1602         push @{$p->{layerconstructor}->{Schema}{Fields}}, {Name => $p->{idfield}, Type => 'Integer'};
1603     }
1604     unless ($p->{elevfield} =~ /^[+-]?\d+$/ or $fields{$p->{elevfield}}) {
1605         my $type = $self->DataType() =~ /Float/ ? 'Real' : 'Integer';
1606         push @{$p->{layerconstructor}->{Schema}{Fields}}, {Name => $p->{elevfield}, Type => $type};
1607     }
1608     my $layer = $p->{datasource}->CreateLayer($p->{layerconstructor});
1609     my $schema = $layer->GetLayerDefn;
1610     for ('idfield', 'elevfield') {
1611         $p->{$_} = $schema->GetFieldIndex($p->{$_}) unless $p->{$_} =~ /^[+-]?\d+$/;
1612     }
1613     $p->{progressdata} = 1 if $p->{progress} and not defined $p->{progressdata};
1614     ContourGenerate($self, $p->{contourinterval}, $p->{contourbase}, $p->{fixedlevels},
1615                     $p->{nodatavalue}, $layer, $p->{idfield}, $p->{elevfield},
1616                     $p->{progress}, $p->{progressdata});
1617     return $layer;
1618 }
1619 
1620 sub FillNodata {
1621     my $self = shift;
1622     my $mask = shift;
1623     $mask = $self->GetMaskBand unless $mask;
1624     my @p = @_;
1625     $p[0] //= 10;
1626     $p[1] //= 0;
1627     Geo::GDAL::FillNodata($self, $mask, @p);
1628 }
1629 *FillNoData = *FillNodata;
1630 *GetBandNumber = *GetBand;
1631 
1632 sub ReadRaster {
1633     my $self = shift;
1634     my ($width, $height) = $self->Size;
1635     my ($type) = $self->DataType;
1636     my $p = named_parameters(\@_,
1637                              XOff => 0,
1638                              YOff => 0,
1639                              XSize => $width,
1640                              YSize => $height,
1641                              BufXSize => undef,
1642                              BufYSize => undef,
1643                              BufType => $type,
1644                              BufPixelSpace => 0,
1645                              BufLineSpace => 0,
1646                              ResampleAlg => 'NearestNeighbour',
1647                              Progress => undef,
1648                              ProgressData => undef
1649         );
1650     $p->{resamplealg} = s2i(rio_resampling => $p->{resamplealg});
1651     $p->{buftype} = s2i(data_type => $p->{buftype}, 1);
1652     $self->_ReadRaster($p->{xoff},$p->{yoff},$p->{xsize},$p->{ysize},$p->{bufxsize},$p->{bufysize},$p->{buftype},$p->{bufpixelspace},$p->{buflinespace},$p->{resamplealg},$p->{progress},$p->{progressdata});
1653 }
1654 
1655 sub WriteRaster {
1656     my $self = shift;
1657     my ($width, $height) = $self->Size;
1658     my ($type) = $self->DataType;
1659     my $p = named_parameters(\@_,
1660                              XOff => 0,
1661                              YOff => 0,
1662                              XSize => $width,
1663                              YSize => $height,
1664                              Buf => undef,
1665                              BufXSize => undef,
1666                              BufYSize => undef,
1667                              BufType => $type,
1668                              BufPixelSpace => 0,
1669                              BufLineSpace => 0
1670         );
1671     confess "Usage: \$band->WriteRaster( Buf => \$data, ... )" unless defined $p->{buf};
1672     $p->{buftype} = s2i(data_type => $p->{buftype}, 1);
1673     $self->_WriteRaster($p->{xoff},$p->{yoff},$p->{xsize},$p->{ysize},$p->{buf},$p->{bufxsize},$p->{bufysize},$p->{buftype},$p->{bufpixelspace},$p->{buflinespace});
1674 }
1675 
1676 sub GetMaskFlags {
1677     my $self = shift;
1678     my $f = $self->_GetMaskFlags;
1679     my @f;
1680     for my $flag (keys %MASK_FLAGS) {
1681         push @f, $flag if $f & $MASK_FLAGS{$flag};
1682     }
1683     return wantarray ? @f : $f;
1684 }
1685 
1686 sub CreateMaskBand {
1687     my $self = shift;
1688     my $f = 0;
1689     if (@_ and $_[0] =~ /^\d$/) {
1690         $f = shift;
1691     } else {
1692         for my $flag (@_) {
1693             carp "Unknown mask flag: '$flag'." unless $MASK_FLAGS{$flag};
1694             $f |= $MASK_FLAGS{$flag};
1695         }
1696     }
1697     $self->_CreateMaskBand($f);
1698 }
1699 
1700 sub Piddle {
1701     # TODO: add Piddle sub to dataset too to make Width x Height x Bands piddles
1702     error("PDL is not available.") unless $Geo::GDAL::HAVE_PDL;
1703     my $self = shift;
1704     my $t = $self->{DataType};
1705     unless (defined wantarray) {
1706         my $pdl = shift;
1707         error("The datatype of the Piddle and the band do not match.")
1708           unless $PDL2DATATYPE{$pdl->get_datatype} == $t;
1709         my ($xoff, $yoff, $xsize, $ysize) = @_;
1710         $xoff //= 0;
1711         $yoff //= 0;
1712         my $data = $pdl->get_dataref();
1713         my ($xdim, $ydim) = $pdl->dims();
1714         if ($xdim > $self->{XSize} - $xoff) {
1715             warn "Piddle XSize too large ($xdim) for this raster band (width = $self->{XSize}, offset = $xoff).";
1716             $xdim = $self->{XSize} - $xoff;
1717         }
1718         if ($ydim > $self->{YSize} - $yoff) {
1719             $ydim = $self->{YSize} - $yoff;
1720             warn "Piddle YSize too large ($ydim) for this raster band (height = $self->{YSize}, offset = $yoff).";
1721         }
1722         $xsize //= $xdim;
1723         $ysize //= $ydim;
1724         $self->_WriteRaster($xoff, $yoff, $xsize, $ysize, $data, $xdim, $ydim, $t, 0, 0);
1725         return;
1726     }
1727     my ($xoff, $yoff, $xsize, $ysize, $xdim, $ydim, $alg) = @_;
1728     $xoff //= 0;
1729     $yoff //= 0;
1730     $xsize //= $self->{XSize} - $xoff;
1731     $ysize //= $self->{YSize} - $yoff;
1732     $xdim //= $xsize;
1733     $ydim //= $ysize;
1734     $alg //= 'NearestNeighbour';
1735     $alg = s2i(rio_resampling => $alg);
1736     my $buf = $self->_ReadRaster($xoff, $yoff, $xsize, $ysize, $xdim, $ydim, $t, 0, 0, $alg);
1737     my $pdl = PDL->new;
1738     my $datatype = $DATATYPE2PDL{$t};
1739     error("The band datatype is not supported by PDL.") if $datatype < 0;
1740     $pdl->set_datatype($datatype);
1741     $pdl->setdims([$xdim, $ydim]);
1742     my $data = $pdl->get_dataref();
1743     $$data = $buf;
1744     $pdl->upd_data;
1745     # FIXME: we want approximate equality since no data value can be very large floating point value
1746     my $bad = GetNoDataValue($self);
1747     return $pdl->setbadif($pdl == $bad) if defined $bad;
1748     return $pdl;
1749 }
1750 
1751 sub GetMaskBand {
1752     my $self = shift;
1753     my $band = _GetMaskBand($self);
1754     keep($band, $self);
1755 }
1756 
1757 sub GetOverview {
1758     my ($self, $index) = @_;
1759     my $band = _GetOverview($self, $index);
1760     keep($band, $self);
1761 }
1762 
1763 sub RegenerateOverview {
1764     my $self = shift;
1765     #Geo::GDAL::Band overview, scalar resampling, subref callback, scalar callback_data
1766     my @p = @_;
1767     Geo::GDAL::RegenerateOverview($self, @p);
1768 }
1769 
1770 sub RegenerateOverviews {
1771     my $self = shift;
1772     #arrayref overviews, scalar resampling, subref callback, scalar callback_data
1773     my @p = @_;
1774     Geo::GDAL::RegenerateOverviews($self, @p);
1775 }
1776 
1777 sub Polygonize {
1778     my $self = shift;
1779     my $p = named_parameters(\@_, Mask => undef, OutLayer => undef, PixValField => 'val', Options => undef, Progress => undef, ProgressData => undef);
1780     my %known_options = (Connectedness => 1, ForceIntPixel => 1, DATASET_FOR_GEOREF => 1, '8CONNECTED' => 1);
1781     for my $option (keys %{$p->{options}}) {
1782         error(1, $option, \%known_options) unless exists $known_options{$option};
1783     }
1784 
1785     my $dt = $self->DataType;
1786     my %leInt32 = (Byte => 1, Int16 => 1, Int32 => 1, UInt16 => 1);
1787     my $leInt32 = $leInt32{$dt};
1788     $dt = $dt =~ /Float/ ? 'Real' : 'Integer';
1789     $p->{outlayer} //= Geo::OGR::Driver('Memory')->Create()->
1790         CreateLayer(Name => 'polygonized',
1791                     Fields => [{Name => 'val', Type => $dt},
1792                                {Name => 'geom', Type => 'Polygon'}]);
1793     $p->{pixvalfield} = $p->{outlayer}->GetLayerDefn->GetFieldIndex($p->{pixvalfield});
1794     $p->{options}{'8CONNECTED'} = 1 if $p->{options}{Connectedness} && $p->{options}{Connectedness} == 8;
1795     if ($leInt32 || $p->{options}{ForceIntPixel}) {
1796         Geo::GDAL::_Polygonize($self, $p->{mask}, $p->{outlayer}, $p->{pixvalfield}, $p->{options}, $p->{progress}, $p->{progressdata});
1797     } else {
1798         Geo::GDAL::FPolygonize($self, $p->{mask}, $p->{outlayer}, $p->{pixvalfield}, $p->{options}, $p->{progress}, $p->{progressdata});
1799     }
1800     set the srs of the outlayer if it was created here
1801     return $p->{outlayer};
1802 }
1803 
1804 sub Sieve {
1805     my $self = shift;
1806     my $p = named_parameters(\@_, Mask => undef, Dest => undef, Threshold => 10, Options => undef, Progress => undef, ProgressData => undef);
1807     unless ($p->{dest}) {
1808         my ($w, $h) = $self->Size;
1809         $p->{dest} = Geo::GDAL::Driver('MEM')->Create(Name => 'sieved', Width => $w, Height => $h, Type => $self->DataType)->Band;
1810     }
1811     my $c = 8;
1812     if ($p->{options}{Connectedness}) {
1813         $c = $p->{options}{Connectedness};
1814         delete $p->{options}{Connectedness};
1815     }
1816     Geo::GDAL::SieveFilter($self, $p->{mask}, $p->{dest}, $p->{threshold}, $c, $p->{options}, $p->{progress}, $p->{progressdata});
1817     return $p->{dest};
1818 }
1819 
1820 sub Distance {
1821     my $self = shift;
1822     my $p = named_parameters(\@_, Distance => undef, Options => undef, Progress => undef, ProgressData => undef);
1823     for my $key (keys %{$p->{options}}) {
1824         $p->{options}{uc($key)} = $p->{options}{$key};
1825     }
1826     $p->{options}{TYPE} //= $p->{options}{DATATYPE} //= 'Float32';
1827     unless ($p->{distance}) {
1828         my ($w, $h) = $self->Size;
1829         $p->{distance} = Geo::GDAL::Driver('MEM')->Create(Name => 'distance', Width => $w, Height => $h, Type => $p->{options}{TYPE})->Band;
1830     }
1831     Geo::GDAL::ComputeProximity($self, $p->{distance}, $p->{options}, $p->{progress}, $p->{progressdata});
1832     return $p->{distance};
1833 }
1834 
1835 
1836 
1837 
1838 package Geo::GDAL::ColorTable;
1839 use strict;
1840 use warnings;
1841 use Carp;
1842 
1843 Geo::GDAL->import(qw(:INTERNAL));
1844 
1845 for (keys %Geo::GDAL::Const::) {
1846     if (/^GPI_(\w+)/) {
1847         my $int = eval "\$Geo::GDAL::Const::GPI_$1";
1848         $Geo::GDAL::S2I{palette_interpretation}{$1} = $int;
1849         $Geo::GDAL::I2S{palette_interpretation}{$int} = $1;
1850     }
1851 }
1852 %}
1853 
1854 %feature("shadow") GDALColorTableShadow(GDALPaletteInterp palette = GPI_RGB)
1855 %{
1856 use Carp;
1857 sub new {
1858     my($pkg, $pi) = @_;
1859     $pi //= 'RGB';
1860     $pi = s2i(palette_interpretation => $pi);
1861     my $self = Geo::GDALc::new_ColorTable($pi);
1862     bless $self, $pkg if defined($self);
1863 }
1864 %}
1865 
1866 %perlcode %{
1867 sub GetPaletteInterpretation {
1868     my $self = shift;
1869     return i2s(palette_interpretation => GetPaletteInterpretation($self));
1870 }
1871 
1872 sub SetColorEntry {
1873     my $self = shift;
1874     my $index = shift;
1875     my $color;
1876     if (ref($_[0]) eq 'ARRAY') {
1877         $color = shift;
1878     } else {
1879         $color = [@_];
1880     }
1881     eval {
1882         $self->_SetColorEntry($index, $color);
1883     };
1884     confess(last_error()) if $@;
1885 }
1886 
1887 sub ColorEntry {
1888     my $self = shift;
1889     my $index = shift // 0;
1890     SetColorEntry($self, $index, @_) if @_;
1891     return unless defined wantarray;
1892     return wantarray ? GetColorEntry($self, $index) : [GetColorEntry($self, $index)];
1893 }
1894 *Color = *ColorEntry;
1895 
1896 sub ColorTable {
1897     my $self = shift;
1898     if (@_) {
1899         my $index = 0;
1900         for my $color (@_) {
1901             ColorEntry($self, $index, $color);
1902             $index++;
1903         }
1904     }
1905     return unless defined wantarray;
1906     my @table;
1907     for (my $index = 0; $index < GetCount($self); $index++) {
1908         push @table, [ColorEntry($self, $index)];
1909     }
1910     return @table;
1911 }
1912 *ColorEntries = *ColorTable;
1913 *Colors = *ColorTable;
1914 
1915 
1916 
1917 
1918 package Geo::GDAL::RasterAttributeTable;
1919 use strict;
1920 use warnings;
1921 use Carp;
1922 
1923 Geo::GDAL->import(qw(:INTERNAL));
1924 
1925 use vars qw(@FIELD_TYPES @FIELD_USAGES);
1926 for (keys %Geo::GDAL::Const::) {
1927     next if /TypeCount/;
1928     push(@FIELD_TYPES, $1), next if /^GFT_(\w+)/;
1929     push(@FIELD_USAGES, $1), next if /^GFU_(\w+)/;
1930 }
1931 for my $string (@FIELD_TYPES) {
1932     my $int = eval "\$Geo::GDAL::Constc::GFT_$string";
1933     $Geo::GDAL::S2I{rat_field_type}{$string} = $int;
1934     $Geo::GDAL::I2S{rat_field_type}{$int} = $string;
1935 }
1936 for my $string (@FIELD_USAGES) {
1937     my $int = eval "\$Geo::GDAL::Constc::GFU_$string";
1938     $Geo::GDAL::S2I{rat_field_usage}{$string} = $int;
1939     $Geo::GDAL::I2S{rat_field_usage}{$int} = $string;
1940 }
1941 
1942 sub FieldTypes {
1943     return @FIELD_TYPES;
1944 }
1945 
1946 sub FieldUsages {
1947     return @FIELD_USAGES;
1948 }
1949 
1950 sub RELEASE_PARENT {
1951     my $self = shift;
1952     unkeep($self);
1953 }
1954 
1955 sub Band {
1956     my $self = shift;
1957     parent($self);
1958 }
1959 
1960 sub GetUsageOfCol {
1961     my($self, $col) = @_;
1962     i2s(rat_field_usage => _GetUsageOfCol($self, $col));
1963 }
1964 
1965 sub GetColOfUsage {
1966     my($self, $usage) = @_;
1967     _GetColOfUsage($self, s2i(rat_field_usage => $usage));
1968 }
1969 
1970 sub GetTypeOfCol {
1971     my($self, $col) = @_;
1972     i2s(rat_field_type => _GetTypeOfCol($self, $col));
1973 }
1974 
1975 sub Columns {
1976     my $self = shift;
1977     my %columns;
1978     if (@_) { # create columns
1979         %columns = @_;
1980         for my $name (keys %columns) {
1981             $self->CreateColumn($name, $columns{$name}{Type}, $columns{$name}{Usage});
1982         }
1983     }
1984     %columns = ();
1985     for my $c (0..$self->GetColumnCount-1) {
1986         my $name = $self->GetNameOfCol($c);
1987         $columns{$name}{Type} = $self->GetTypeOfCol($c);
1988         $columns{$name}{Usage} = $self->GetUsageOfCol($c);
1989     }
1990     return %columns;
1991 }
1992 
1993 sub CreateColumn {
1994     my($self, $name, $type, $usage) = @_;
1995     for my $color (qw/Red Green Blue Alpha/) {
1996         carp "RAT column type will be 'Integer' for usage '$color'." if $usage eq $color and $type ne 'Integer';
1997     }
1998     $type = s2i(rat_field_type => $type);
1999     $usage = s2i(rat_field_usage => $usage);
2000     _CreateColumn($self, $name, $type, $usage);
2001 }
2002 
2003 sub Value {
2004     my($self, $row, $column) = @_;
2005     SetValueAsString($self, $row, $column, $_[3]) if defined $_[3];
2006     return unless defined wantarray;
2007     GetValueAsString($self, $row, $column);
2008 }
2009 
2010 sub LinearBinning {
2011     my $self = shift;
2012     SetLinearBinning($self, @_) if @_ > 0;
2013     return unless defined wantarray;
2014     my @a = GetLinearBinning($self);
2015     return $a[0] ? ($a[1], $a[2]) : ();
2016 }
2017 
2018 
2019 
2020 
2021 package Geo::GDAL::GCP;
2022 
2023 *swig_Pixel_get = *Geo::GDALc::GCP_Column_get;
2024 *swig_Pixel_set = *Geo::GDALc::GCP_Column_set;
2025 *swig_Line_get = *Geo::GDALc::GCP_Row_get;
2026 *swig_Line_set = *Geo::GDALc::GCP_Row_set;
2027 
2028 Geo::GDAL->import(qw(:INTERNAL));
2029 
2030 package Geo::GDAL::VSIF;
2031 use strict;
2032 use warnings;
2033 use Carp;
2034 require Exporter;
2035 our @ISA = qw(Exporter);
2036 
2037 our @EXPORT_OK   = qw(Open Close Write Read Seek Tell Truncate MkDir ReadDir ReadDirRecursive Rename RmDir Stat Unlink);
2038 our %EXPORT_TAGS = (all => \@EXPORT_OK);
2039 
2040 Geo::GDAL->import(qw(:INTERNAL));
2041 
2042 sub Open {
2043     my ($path, $mode) = @_;
2044     my $self = Geo::GDAL::VSIFOpenL($path, $mode);
2045     bless $self, 'Geo::GDAL::VSIF';
2046 }
2047 
2048 sub Write {
2049     my ($self, $data) = @_;
2050     Geo::GDAL::VSIFWriteL($data, $self);
2051 }
2052 
2053 sub Close {
2054     my ($self) = @_;
2055     Geo::GDAL::VSIFCloseL($self);
2056 }
2057 
2058 sub Read {
2059     my ($self, $count) = @_;
2060     Geo::GDAL::VSIFReadL($count, $self);
2061 }
2062 
2063 sub Seek {
2064     my ($self, $offset, $whence) = @_;
2065     Geo::GDAL::VSIFSeekL($self, $offset, $whence);
2066 }
2067 
2068 sub Tell {
2069     my ($self) = @_;
2070     Geo::GDAL::VSIFTellL($self);
2071 }
2072 
2073 sub Flush {
2074     my ($self) = @_;
2075     Geo::GDAL::VSIFFlushL($self);
2076 }
2077 
2078 sub Truncate {
2079     my ($self, $new_size) = @_;
2080     Geo::GDAL::VSIFTruncateL($self, $new_size);
2081 }
2082 
2083 sub MkDir {
2084     my ($path) = @_;
2085     # mode unused in CPL
2086     Geo::GDAL::Mkdir($path, 0);
2087 }
2088 *Mkdir = *MkDir;
2089 
2090 sub ReadDir {
2091     my ($path) = @_;
2092     Geo::GDAL::ReadDir($path);
2093 }
2094 
2095 sub ReadDirRecursive {
2096     my ($path) = @_;
2097     Geo::GDAL::ReadDirRecursive($path);
2098 }
2099 
2100 sub Rename {
2101     my ($old, $new) = @_;
2102     Geo::GDAL::Rename($old, $new);
2103 }
2104 
2105 sub RmDir {
2106     my ($dirname, $recursive) = @_;
2107     eval {
2108         if (!$recursive) {
2109             Geo::GDAL::Rmdir($dirname);
2110         } else {
2111             for my $f (ReadDir($dirname)) {
2112                 next if $f eq '..' or $f eq '.';
2113                 my @s = Stat($dirname.'/'.$f);
2114                 if ($s[0] eq 'f') {
2115                     Unlink($dirname.'/'.$f);
2116                 } elsif ($s[0] eq 'd') {
2117                     Rmdir($dirname.'/'.$f, 1);
2118                     Rmdir($dirname.'/'.$f);
2119                 }
2120             }
2121             RmDir($dirname);
2122         }
2123     };
2124     if ($@) {
2125         my $r = $recursive ? ' recursively' : '';
2126         error("Cannot remove directory \"$dirname\"$r.");
2127     }
2128 }
2129 *Rmdir = *RmDir;
2130 
2131 sub Stat {
2132     my ($path) = @_;
2133     Geo::GDAL::Stat($path);
2134 }
2135 
2136 sub Unlink {
2137     my ($filename) = @_;
2138     Geo::GDAL::Unlink($filename);
2139 }
2140 
2141 
2142 
2143 
2144 package Geo::GDAL::GeoTransform;
2145 use strict;
2146 use warnings;
2147 use Carp;
2148 use Scalar::Util 'blessed';
2149 
2150 Geo::GDAL->import(qw(:INTERNAL));
2151 
2152 sub new {
2153     my $class = shift;
2154     my $self;
2155     if (@_ == 0) {
2156         $self = [0,1,0,0,0,1];
2157     } elsif (ref $_[0]) {
2158         @$self = @{$_[0]};
2159     } elsif ($_[0] =~ /^[a-zA-Z]/i) {
2160         my $p = named_parameters(\@_, GCPs => undef, ApproxOK => 1, Extent => undef, CellSize => 1);
2161         if ($p->{gcps}) {
2162             $self = Geo::GDAL::GCPsToGeoTransform($p->{gcps}, $p->{approxok});
2163         } elsif ($p->{extent}) {
2164             $self = Geo::GDAL::GeoTransform->new($p->{extent}[0], $p->{cellsize}, 0, $p->{extent}[2], 0, -$p->{cellsize});
2165         } else {
2166             error("Missing GCPs or Extent");
2167         }
2168     } else {
2169         my @a = @_;
2170         $self = \@a;
2171     }
2172     bless $self, $class;
2173 }
2174 
2175 sub NorthUp {
2176     my $self = shift;
2177     return $self->[2] == 0 && $self->[4] == 0;
2178 }
2179 
2180 sub FromGCPs {
2181     my $gcps;
2182     my $p = shift;
2183     if (ref $p eq 'ARRAY') {
2184         $gcps = $p;
2185     } else {
2186         $gcps = [];
2187         while ($p && blessed $p) {
2188             push @$gcps, $p;
2189             $p = shift;
2190         }
2191     }
2192     my $approx_ok = shift // 1;
2193     error('Usage: Geo::GDAL::GeoTransform::FromGCPs(\@gcps, $approx_ok)') unless @$gcps;
2194     my $self = Geo::GDAL::GCPsToGeoTransform($gcps, $approx_ok);
2195     bless $self, 'Geo::GDAL::GetTransform';
2196     return $self;
2197 }
2198 
2199 sub Apply {
2200     my ($self, $columns, $rows) = @_;
2201     return Geo::GDAL::ApplyGeoTransform($self, $columns, $rows) unless ref($columns) eq 'ARRAY';
2202     my (@x, @y);
2203     for my $i (0..$#$columns) {
2204         ($x[$i], $y[$i]) =
2205             Geo::GDAL::ApplyGeoTransform($self, $columns->[$i], $rows->[$i]);
2206     }
2207     return (\@x, \@y);
2208 }
2209 
2210 sub Inv {
2211     my $self = shift;
2212     my @inv = Geo::GDAL::InvGeoTransform($self);
2213     return Geo::GDAL::GeoTransform->new(@inv) if defined wantarray;
2214     @$self = @inv;
2215 }
2216 
2217 sub Extent {
2218     my ($self, $w, $h) = @_;
2219     my $e = Geo::GDAL::Extent->new($self->[0], $self->[3], $self->[0], $self->[3]);
2220     for my $x ($self->[0] + $self->[1]*$w, $self->[0] + $self->[2]*$h, $self->[0] + $self->[1]*$w + $self->[2]*$h) {
2221         $e->[0] = $x if $x < $e->[0];
2222         $e->[2] = $x if $x > $e->[2];
2223     }
2224     for my $y ($self->[3] + $self->[4]*$w, $self->[3] + $self->[5]*$h, $self->[3] + $self->[4]*$w + $self->[5]*$h) {
2225         $e->[1] = $y if $y < $e->[1];
2226         $e->[3] = $y if $y > $e->[3];
2227     }
2228     return $e;
2229 }
2230 
2231 package Geo::GDAL::Extent; # array 0=xmin|left, 1=ymin|bottom, 2=xmax|right, 3=ymax|top
2232 
2233 use strict;
2234 use warnings;
2235 use Carp;
2236 use Scalar::Util 'blessed';
2237 
2238 Geo::GDAL->import(qw(:INTERNAL));
2239 
2240 sub new {
2241     my $class = shift;
2242     my $self;
2243     if (@_ == 0) {
2244         $self = [0,0,-1,0];
2245     } elsif (ref $_[0]) {
2246         @$self = @{$_[0]};
2247     } else {
2248         @$self = @_;
2249     }
2250     bless $self, $class;
2251     return $self;
2252 }
2253 
2254 sub IsEmpty {
2255     my $self = shift;
2256     return $self->[2] < $self->[0];
2257 }
2258 
2259 sub Size {
2260     my $self = shift;
2261     return (0,0) if $self->IsEmpty;
2262     return ($self->[2] - $self->[0], $self->[3] - $self->[1]);
2263 }
2264 
2265 sub Overlaps {
2266     my ($self, $e) = @_;
2267     return $self->[0] < $e->[2] && $self->[2] > $e->[0] && $self->[1] < $e->[3] && $self->[3] > $e->[1];
2268 }
2269 
2270 sub Overlap {
2271     my ($self, $e) = @_;
2272     return Geo::GDAL::Extent->new() unless $self->Overlaps($e);
2273     my $ret = Geo::GDAL::Extent->new($self);
2274     $ret->[0] = $e->[0] if $self->[0] < $e->[0];
2275     $ret->[1] = $e->[1] if $self->[1] < $e->[1];
2276     $ret->[2] = $e->[2] if $self->[2] > $e->[2];
2277     $ret->[3] = $e->[3] if $self->[3] > $e->[3];
2278     return $ret;
2279 }
2280 
2281 sub ExpandToInclude {
2282     my ($self, $e) = @_;
2283     return if $e->IsEmpty;
2284     if ($self->IsEmpty) {
2285         @$self = @$e;
2286     } else {
2287         $self->[0] = $e->[0] if $e->[0] < $self->[0];
2288         $self->[1] = $e->[1] if $e->[1] < $self->[1];
2289         $self->[2] = $e->[2] if $e->[2] > $self->[2];
2290         $self->[3] = $e->[3] if $e->[3] > $self->[3];
2291     }
2292 }
2293 
2294 package Geo::GDAL::XML;
2295 
2296 use strict;
2297 use warnings;
2298 use Carp;
2299 
2300 Geo::GDAL->import(qw(:INTERNAL));
2301 
2302 # XML related subs in Geo::GDAL
2303 
2304 #Geo::GDAL::Child
2305 #Geo::GDAL::Children
2306 #Geo::GDAL::NodeData
2307 #Geo::GDAL::NodeType
2308 #Geo::GDAL::NodeTypes
2309 #Geo::GDAL::ParseXMLString
2310 #Geo::GDAL::SerializeXMLTree
2311 
2312 sub new {
2313     my $class = shift;
2314     my $xml = shift // '';
2315     my $self = ParseXMLString($xml);
2316     bless $self, $class;
2317     $self->traverse(sub {my $node = shift; bless $node, $class});
2318     return $self;
2319 }
2320 
2321 sub traverse {
2322     my ($self, $sub) = @_;
2323     my $type = $self->[0];
2324     my $data = $self->[1];
2325     $type = NodeType($type);
2326     $sub->($self, $type, $data);
2327     for my $child (@{$self}[2..$#$self]) {
2328         traverse($child, $sub);
2329     }
2330 }
2331 
2332 sub serialize {
2333     my $self = shift;
2334     return SerializeXMLTree($self);
2335 }
2336 
2337 %}
2338