File Coverage

blib/lib/Geo/GDAL/FFI/Band.pm
Criterion Covered Total %
statement 179 198 90.4
branch 17 46 36.9
condition 35 60 58.3
subroutine 22 26 84.6
pod 15 20 75.0
total 268 350 76.5


line stmt bran cond sub pod time code
1             package Geo::GDAL::FFI::Band;
2 5     5   64 use v5.10;
  5         19  
3 5     5   26 use strict;
  5         14  
  5         198  
4 5     5   108 use warnings;
  5         17  
  5         152  
5 5     5   27 use Carp;
  5         14  
  5         322  
6 5     5   39 use FFI::Platypus::Buffer;
  5         8  
  5         12073  
7              
8             our $VERSION = 0.0800;
9              
10             sub DESTROY {
11 3     3   1404 my $self = shift;
12 3         19 Geo::GDAL::FFI::_deregister_parent_ref ($$self);
13             }
14              
15             sub GetDataType {
16 0     0 1 0 my $self = shift;
17 0         0 return $Geo::GDAL::FFI::data_types_reverse{Geo::GDAL::FFI::GDALGetRasterDataType($$self)};
18             }
19              
20             sub GetWidth {
21 0     0 0 0 my $self = shift;
22 0         0 Geo::GDAL::FFI::GDALGetRasterBandXSize($$self);
23             }
24              
25             sub GetHeight {
26 0     0 0 0 my $self = shift;
27 0         0 Geo::GDAL::FFI::GDALGetRasterBandYSize($$self);
28             }
29              
30             sub GetSize {
31 5     5 1 9 my $self = shift;
32             return (
33 5         29 Geo::GDAL::FFI::GDALGetRasterBandXSize($$self),
34             Geo::GDAL::FFI::GDALGetRasterBandYSize($$self)
35             );
36             }
37              
38             sub GetCategoryNames {
39 1     1 0 10 my $self = shift;
40 1         5 my $csl = Geo::GDAL::FFI::GDALGetRasterCategoryNames($$self);
41 1         2 my @names;
42 1         15 for my $i (0..Geo::GDAL::FFI::CSLCount($csl)-1) {
43 2         20 push @names, Geo::GDAL::FFI::CSLGetField($csl, $i);
44             }
45 1         5 return @names;
46             }
47              
48             sub SetCategoryNames {
49 1     1 0 395 my ($self, @names) = @_;
50 1         3 my $csl = 0;
51 1         3 for my $n (@names) {
52 2         15 $csl = Geo::GDAL::FFI::CSLAddString($csl, $n);
53             }
54 1         24 Geo::GDAL::FFI::GDALSetRasterCategoryNames($$self, $csl);
55 1         8 Geo::GDAL::FFI::CSLDestroy($csl);
56             }
57              
58             sub GetNoDataValue {
59 5     5 1 599 my $self = shift;
60 5         10 my $b = 0;
61 5         35 my $v = Geo::GDAL::FFI::GDALGetRasterNoDataValue($$self, \$b);
62 5 100       22 return unless $b;
63 1         3 return $v;
64             }
65              
66             sub SetNoDataValue {
67 2     2 1 633 my $self = shift;
68 2 100       8 unless (@_) {
69 1         8 Geo::GDAL::FFI::GDALDeleteRasterNoDataValue($$self);
70 1         3 return;
71             }
72 1         3 my $v = shift;
73 1         8 my $e = Geo::GDAL::FFI::GDALSetRasterNoDataValue($$self, $v);
74 1 50       5 return unless $e;
75 0   0     0 confess Geo::GDAL::FFI::error_msg() // "SetNoDataValue not supported by the driver.";
76             }
77              
78             sub GetBlockSize {
79 1     1 1 19 my $self = shift;
80 1         3 my ($w, $h);
81 1         18 Geo::GDAL::FFI::GDALGetBlockSize($$self, \$w, \$h);
82 1         5 return ($w, $h);
83             }
84              
85             sub pack_char {
86 15     15 0 27 my $t = shift;
87 15         72 my $is_big_endian = unpack("h*", pack("s", 1)) =~ /01/; # from Programming Perl
88 15 50       63 return ('C', 1) if $t == 1;
89 0 0       0 return ($is_big_endian ? ('n', 2) : ('v', 2)) if $t == 2;
    0          
90 0 0       0 return ('s', 2) if $t == 3;
91 0 0       0 return ($is_big_endian ? ('N', 4) : ('V', 4)) if $t == 4;
    0          
92 0 0       0 return ('l', 4) if $t == 5;
93 0 0       0 return ('f', 4) if $t == 6;
94 0 0       0 return ('d', 8) if $t == 7;
95             # CInt16 => 8,
96             # CInt32 => 9,
97             # CFloat32 => 10,
98             # CFloat64 => 11
99             }
100              
101             sub Read {
102 5     5 1 58 my ($self, $xoff, $yoff, $xsize, $ysize, $bufxsize, $bufysize) = @_;
103 5   100     25 $xoff //= 0;
104 5   100     19 $yoff //= 0;
105 5         31 my $t = Geo::GDAL::FFI::GDALGetRasterDataType($$self);
106 5         16 my ($pc, $bytes_per_cell) = pack_char($t);
107 5         19 my $w;
108 5   66     30 $xsize //= Geo::GDAL::FFI::GDALGetRasterBandXSize($$self);
109 5   66     30 $ysize //= Geo::GDAL::FFI::GDALGetRasterBandYSize($$self);
110 5   33     23 $bufxsize //= $xsize;
111 5   33     41 $bufysize //= $ysize;
112 5         10 $w = $bufxsize * $bytes_per_cell;
113 5         17 my $buf = ' ' x ($bufysize * $w);
114 5         23 my ($pointer, $size) = scalar_to_buffer $buf;
115 5         168 Geo::GDAL::FFI::GDALRasterIO($$self, $Geo::GDAL::FFI::Read, $xoff, $yoff, $xsize, $ysize, $pointer, $bufxsize, $bufysize, $t, 0, 0);
116 5         14 my $offset = 0;
117 5         10 my @data;
118 5         25 for my $y (0..$bufysize-1) {
119 62         178 my @d = unpack($pc."[$bufxsize]", substr($buf, $offset, $w));
120 62         98 push @data, \@d;
121 62         105 $offset += $w;
122             }
123 5         48 return \@data;
124             }
125              
126             sub ReadBlock {
127 2     2 1 19 my ($self, $xoff, $yoff, $xsize, $ysize, $t) = @_;
128 2   50     22 $xoff //= 0;
129 2   50     11 $yoff //= 0;
130 2 50       24 Geo::GDAL::FFI::GDALGetBlockSize($$self, \$xsize, \$ysize) unless defined $xsize;
131 2 50       12 $t = Geo::GDAL::FFI::GDALGetRasterDataType($$self) unless defined $t;
132 2         4 my $buf;
133 2         6 my ($pc, $bytes_per_cell) = pack_char($t);
134 2         3 my $w = $xsize * $bytes_per_cell;
135 2         10 $buf = ' ' x ($ysize * $w);
136 2         7 my ($pointer, $size) = scalar_to_buffer $buf;
137 2         69 Geo::GDAL::FFI::GDALReadBlock($$self, $xoff, $yoff, $pointer);
138 2         6 my $offset = 0;
139 2         4 my @data;
140 2         8 for my $y (0..$ysize-1) {
141 64         1125 my @d = unpack($pc."[$xsize]", substr($buf, $offset, $w));
142 64         167 push @data, \@d;
143 64         116 $offset += $w;
144             }
145 2         103 return \@data;
146             }
147              
148             sub Write {
149 5     5 1 1241 my ($self, $data, $xoff, $yoff, $xsize, $ysize) = @_;
150 5   50     45 $xoff //= 0;
151 5   50     27 $yoff //= 0;
152 5         8 my $bufxsize = @{$data->[0]};
  5         13  
153 5         12 my $bufysize = @$data;
154 5   33     32 $xsize //= $bufxsize;
155 5   33     23 $ysize //= $bufysize;
156 5         31 my $t = Geo::GDAL::FFI::GDALGetRasterDataType($$self);
157 5         18 my ($pc, $bytes_per_cell) = pack_char($t);
158 5         15 my $buf = '';
159 5         19 for my $i (0..$bufysize-1) {
160 62         96 $buf .= pack($pc."[$bufxsize]", @{$data->[$i]});
  62         148  
161             }
162 5         25 my ($pointer, $size) = scalar_to_buffer $buf;
163 5         502 Geo::GDAL::FFI::GDALRasterIO($$self, $Geo::GDAL::FFI::Write, $xoff, $yoff, $xsize, $ysize, $pointer, $bufxsize, $bufysize, $t, 0, 0);
164             }
165              
166             sub WriteBlock {
167 1     1 1 447 my ($self, $data, $xoff, $yoff) = @_;
168 1         4 my ($xsize, $ysize);
169 1         9 Geo::GDAL::FFI::GDALGetBlockSize($$self, \$xsize, \$ysize);
170 1         5 my $t = Geo::GDAL::FFI::GDALGetRasterDataType($$self);
171 1         4 my ($pc, $bytes_per_cell) = pack_char($t);
172 1         4 my $buf = '';
173 1         12 for my $i (0..$ysize-1) {
174 32         54 $buf .= pack($pc."[$xsize]", @{$data->[$i]});
  32         186  
175             }
176 1         6 my ($pointer, $size) = scalar_to_buffer $buf;
177 1         57 Geo::GDAL::FFI::GDALWriteBlock($$self, $xoff, $yoff, $pointer);
178             }
179              
180             sub GetColorInterpretation {
181 0     0 1 0 my $self = shift;
182             return $Geo::GDAL::FFI::color_interpretations_reverse{
183 0         0 Geo::GDAL::FFI::GDALGetRasterColorInterpretation($$self)
184             };
185             }
186              
187             sub SetColorInterpretation {
188 1     1 1 992 my ($self, $i) = @_;
189 1         4 my $tmp = $Geo::GDAL::FFI::color_interpretations{$i};
190 1 50       6 confess "Unknown color interpretation: $i." unless defined $tmp;
191 1         2 $i = $tmp;
192 1         9 Geo::GDAL::FFI::GDALSetRasterColorInterpretation($$self, $i);
193             }
194              
195             sub GetColorTable {
196 1     1 1 7 my $self = shift;
197 1         14 my $ct = Geo::GDAL::FFI::GDALGetRasterColorTable($$self);
198 1 50       5 return unless $ct;
199             # color table is a table of [c1...c4]
200             # the interpretation of colors is from next method
201 1         3 my @table;
202 1         8 for my $i (0..Geo::GDAL::FFI::GDALGetColorEntryCount($ct)-1) {
203 2         14 my $c = Geo::GDAL::FFI::GDALGetColorEntry($ct, $i);
204 2         5 push @table, $c;
205             }
206 1 50       8 return wantarray ? @table : \@table;
207             }
208              
209             sub SetColorTable {
210 1     1 1 11 my ($self, $table) = @_;
211 1         18 my $ct = Geo::GDAL::FFI::GDALCreateColorTable();
212 1         5 for my $i (0..$#$table) {
213 2         108 Geo::GDAL::FFI::GDALSetColorEntry($ct, $i, $table->[$i]);
214             }
215 1         62 Geo::GDAL::FFI::GDALSetRasterColorTable($$self, $ct);
216 1         13 Geo::GDAL::FFI::GDALDestroyColorTable($ct);
217             }
218              
219             sub GetPiddle {
220 2     2 1 946 my ($self, $xoff, $yoff, $xsize, $ysize, $xdim, $ydim, $alg) = @_;
221 2   100     9 $xoff //= 0;
222 2   100     8 $yoff //= 0;
223 2         5 my ($w, $h) = $self->GetSize;
224 2   66     9 $xsize //= $w - $xoff;
225 2   66     11 $ysize //= $h - $yoff;
226 2         8 my $t = Geo::GDAL::FFI::GDALGetRasterDataType($$self);
227 2         10 my $pdl_t = $Geo::GDAL::FFI::data_type2pdl_data_type{$Geo::GDAL::FFI::data_types_reverse{$t}};
228 2 50       6 confess "The Piddle data_type is unsuitable." unless defined $pdl_t;
229 2   33     9 $xdim //= $xsize;
230 2   33     11 $ydim //= $ysize;
231 2   50     10 $alg //= 'NearestNeighbour';
232 2         7 my $tmp = $Geo::GDAL::FFI::resampling{$alg};
233 2 50       5 confess "Unknown resampling scheme: $alg." unless defined $tmp;
234 2         4 $alg = $tmp;
235 2         13 my $bufxsize = $xsize;
236 2         6 my $bufysize = $ysize;
237 2         6 my ($pc, $bytes_per_cell) = pack_char($t);
238 2         9 my $buf = ' ' x ($bufysize * $bufxsize * $bytes_per_cell);
239 2         9 my ($pointer, $size) = scalar_to_buffer $buf;
240 2         31 Geo::GDAL::FFI::GDALRasterIO($$self, $Geo::GDAL::FFI::Read, $xoff, $yoff, $xsize, $ysize, $pointer, $bufxsize, $bufysize, $t, 0, 0);
241 2         22 my $pdl = PDL->new;
242 2         246 $pdl->set_datatype($pdl_t);
243 2         9 $pdl->setdims([$xdim, $ydim]);
244 2         9 my $data = $pdl->get_dataref();
245             # FIXME: see http://pdl.perl.org/PDLdocs/API.html how to wrap $buf into a piddle
246 2         4 $$data = $buf;
247 2         7 $pdl->upd_data;
248             # FIXME: we want approximate equality since no data value can be very large floating point value
249 2         7 my $bad = GetNoDataValue($self);
250 2 50       5 return $pdl->setbadif($pdl == $bad) if defined $bad;
251 2         15 return $pdl;
252             }
253              
254             sub SetPiddle {
255 3     3 1 12 my ($self, $pdl, $xoff, $yoff, $xsize, $ysize) = @_;
256 3   100     11 $xoff //= 0;
257 3   100     10 $yoff //= 0;
258 3         10 my ($w, $h) = $self->GetSize;
259 3         19 my $t = $Geo::GDAL::FFI::pdl_data_type2data_type{$pdl->get_datatype};
260 3 50       8 confess "The Piddle data_type '".$pdl->get_datatype."' is unsuitable." unless defined $t;
261 3         8 $t = $Geo::GDAL::FFI::data_types{$t};
262 3         11 my ($xdim, $ydim) = $pdl->dims();
263 3   66     81 $xsize //= $xdim;
264 3   66     12 $ysize //= $ydim;
265 3 50       9 if ($xdim > $w - $xoff) {
266 0         0 warn "Piddle too wide ($xdim) for this raster band (width = $w, offset = $xoff).";
267 0         0 $xdim = $w - $xoff;
268             }
269 3 50       9 if ($ydim > $h - $yoff) {
270 0         0 $ydim = $h - $yoff;
271 0         0 warn "Piddle too tall ($ydim) for this raster band (height = $h, offset = $yoff).";
272             }
273 3         9 my $data = $pdl->get_dataref();
274 3         9 my ($pointer, $size) = scalar_to_buffer $$data;
275 3         324 Geo::GDAL::FFI::GDALRasterIO($$self, $Geo::GDAL::FFI::Write, $xoff, $yoff, $xsize, $ysize, $pointer, $xdim, $ydim, $t, 0, 0);
276             }
277              
278             1;
279              
280             =pod
281              
282             =encoding UTF-8
283              
284             =head1 NAME
285              
286             Geo::GDAL::FFI::Band - A GDAL raster band
287              
288             =head1 SYNOPSIS
289              
290             =head1 DESCRIPTION
291              
292             A band (channel) in a raster dataset. Use the Band method of a dataset
293             object to obtain a band object.
294              
295             =head1 METHODS
296              
297             =head2 GetDataType
298              
299             my $datatype = $band->GetDataType;
300              
301             =head2 GetSize
302              
303             my @size = $band->GetSize;
304              
305             =head2 GetBlockSize
306              
307             my @size = $band->GetBlockSize;
308              
309             =head2 GetNoDataValue
310              
311             my $nodata = $band->GetNoDataValue;
312              
313             =head2 SetNoDataValue
314              
315             $band->SetNoDataValue($value);
316              
317             Calling the method without arguments deletes the nodata value.
318              
319             $band->SetNoDataValue;
320              
321             =head2 Read
322              
323             my $data = $band->Read($xoff, $yoff, $xsize, $ysize, $bufxsize, $bufysize);
324              
325             All arguments are optional. If no arguments are given, reads the whole
326             raster band into a 2D Perl array. The returned array is an array of
327             references to arrays of row values.
328              
329             =head2 ReadBlock
330              
331             my $data = $band->ReadBlock($xoff, $yoff, @blocksize, $datatype);
332              
333             Reads a block of data from the band and returns it as a Perl 2D
334             array. C<@blocksize> and C<$datatype> (an integer) are optional and
335             obtained from the GDAL raster object if not given.
336              
337             =head2 Write
338              
339             $band->Write($data, $xoff, $yoff, $xsize, $ysize);
340              
341             =head2 WriteBlock
342              
343             $band->WriteBlock($data, $xoff, $yoff);
344              
345             =head2 SetPiddle
346              
347             $band->SetPiddle($pdl, $xoff, $yoff, $xsize, $ysize);
348              
349             Read data from a piddle into this Band.
350              
351             =head2 GetPiddle
352              
353             $band->GetPiddle($xoff, $yoff, $xsize, $ysize, $xdim, $ydim);
354              
355             Read data from this Band into a piddle.
356              
357             =head2 GetColorInterpretation
358              
359             my $ci = $band->GetColorInterpretation;
360              
361             =head2 SetColorInterpretation
362              
363             $band->SetColorInterpretation($ci);
364              
365             =head2 GetColorTable
366              
367             my $color_table = $band->GetColorTable;
368              
369             Returns the color table as an array of arrays. The inner tables are
370             colors [c1...c4].
371              
372             =head2 SetColorTable
373              
374             $band->SetColorTable($color_table);
375              
376             =head1 LICENSE
377              
378             This software is released under the Artistic License. See
379             L.
380              
381             =head1 AUTHOR
382              
383             Ari Jolma - Ari.Jolma at gmail.com
384              
385             =head1 SEE ALSO
386              
387             L
388              
389             L, L, L
390              
391             =cut
392              
393             __END__;