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]; elsif($@)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