File Coverage

blib/lib/Astro/FITS/CFITSIO/Simple/Table.pm
Criterion Covered Total %
statement 244 268 91.0
branch 94 134 70.1
condition 39 69 56.5
subroutine 17 18 94.4
pod 0 2 0.0
total 394 491 80.2


line stmt bran cond sub pod time code
1             package Astro::FITS::CFITSIO::Simple::Table;
2              
3             # ABSTRACT: Read FITS Tables
4              
5 11     11   193 use 5.008002;
  11         43  
6 11     11   63 use strict;
  11         26  
  11         212  
7 11     11   49 use warnings;
  11         25  
  11         370  
8              
9             require Exporter;
10              
11 11     11   61 use Params::Validate qw/ :all /;
  11         22  
  11         1783  
12              
13 11     11   88 use Carp;
  11         56  
  11         574  
14              
15 11     11   78 use POSIX ();
  11         29  
  11         270  
16 11     11   57 use Scalar::Util qw/blessed/;
  11         27  
  11         526  
17 11     11   73 use PDL;
  11         22  
  11         90  
18 11     11   31470 use PDL::Core qw[ byte ushort long ];
  11         25  
  11         47  
19              
20 11     11   826 use Astro::FITS::CFITSIO qw/ :constants /;
  11         23  
  11         9156  
21 11     11   83 use Astro::FITS::CFITSIO::CheckStatus;
  11         26  
  11         284  
22 11     11   4858 use Astro::FITS::CFITSIO::Simple::PDL qw/ :all /;
  11         32  
  11         1247  
23 11     11   78 use Astro::FITS::Header;
  11         24  
  11         282  
24 11     11   4761 use Astro::FITS::Header::CFITSIO;
  11         43661  
  11         32211  
25              
26             our @ISA = qw(Exporter);
27              
28             our %EXPORT_TAGS = (
29             'all' => [ qw(
30             _rdfitsTable
31             ) ] );
32              
33             our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
34              
35             our @EXPORT = qw(
36              
37             );
38              
39             our $VERSION = '0.20';
40              
41             # this must be called ONLY from rdfits. it makes assumptions about
42             # the validity of arguments that have been verified by rdfits.
43              
44             sub _rdfitsTable {
45              
46 27 50   27   122 my $opts = 'HASH' eq ref $_[-1] ? pop : {};
47              
48             # first arg is fitsfilePtr
49             # second is cleanup object; must keep around until we're done,
50             # so it'll cleanup at the correct time.
51 27         55 my $fptr = shift;
52              
53 27 50       71 croak( "column names must be scalars\n" ) if grep { ref $_ } @_;
  28         82  
54              
55 27         70 my @req_cols = map { lc $_ } @_;
  28         79  
56              
57              
58             my %opt = validate_with(
59             params => [$opts],
60 277     277   1153 normalize_keys => sub { lc $_[0] },
61 27         863 spec => {
62             nullval => { type => SCALAR, optional => 1 },
63             rfilter => { type => SCALAR, optional => 1 },
64             dtypes => { type => HASHREF, optional => 1 },
65             defdtype => { isa => qw[ PDL::Type ], optional => 1 },
66             ninc => { type => SCALAR, optional => 1 },
67             rethash => { type => SCALAR, default => 0 },
68             retinfo => { type => SCALAR, default => 0 },
69             rethdr => { type => SCALAR, default => 0 },
70             status => {
71             callbacks => {
72             "boolean, filehandle, subroutine, or object" =>
73             \&validate_status
74             },
75             optional => 1
76             },
77             } );
78              
79             # data structure describing the columns
80 27         333 my %cols;
81              
82             # final list of columns (not column names!)
83             my @cols;
84              
85             # CFITSIO status variable
86 27         130 tie my $status, 'Astro::FITS::CFITSIO::CheckStatus';
87              
88             # normalize column names for user specified types.
89             my %user_types
90 27         1153 = map { lc( $_ ) => $opt{dtypes}{$_} } keys %{ $opt{dtypes} };
  11         51  
  27         109  
91              
92              
93             # see if we're to delete columns
94             my @del_cols
95 27         80 = map { ( my $col = $_ ) =~ s/-//; $col } grep { /^-/ } @req_cols;
  1         5  
  1         5  
  28         82  
96              
97             # if columns are to be deleted, can't have any other things in the list
98 27 50 66     108 die( "can't mix -col and col specifictions in list of columns\n" )
99             if @del_cols && @del_cols != @req_cols;
100              
101 27 100       88 @req_cols = ()
102             if @del_cols;
103              
104 27         64 my %del_cols = map { ( $_ => 1 ) } @del_cols;
  1         4  
105              
106              
107             # hash of requested column names (if any); used to track
108             # non-existant columns
109 27         54 my %req_cols = map { ( $_ => 0 ) } @req_cols;
  27         73  
110              
111             # by default return a hash of data unless columns are requested
112             # (del_cols don't count)
113 27 100 100     138 $opt{rethash} = 1 unless @req_cols || $opt{retinfo};
114              
115             # grab header
116 27         244 my $hdr = Astro::FITS::Header::CFITSIO->new( fitsID => $fptr );
117              
118             # grab the number of columns and rows in the HDU
119 27         118492 $fptr->get_num_cols( my $ncols, $status );
120 27         652 $fptr->get_num_rows( my $nrows, $status );
121              
122             # this is the number of rows to process at one time.
123 27         396 my $ninc = $opt{ninc};
124 27 100       128 $ninc or $fptr->get_rowsize( $ninc, $status );
125 27 100       233 $ninc = $nrows if $nrows < $ninc;
126              
127             # use transfer buffers until we can figure out how to read chunks
128             # directly into the final piddles. These are indexed off of the
129             # shape of the piddle so that we can reuse them and save memory.
130 27         55 my %tmppdl;
131              
132             # create data structure describing the columns
133 27         70 for my $coln ( 1 .. $ncols ) {
134              
135 147         446 $fptr->get_colname( CASEINSEN, $coln, my $oname, undef, $status );
136 147         3856 my $name = lc $oname;
137              
138             # blank name! can't have that. unlike PDL::IO::FITS we just
139             # number 'em after the actual column position.
140 147 50       336 $name = "col_$coln" if '' eq $name;
141              
142             # check for dups; can't have that either! Follow PDL::IO::FITS
143             # convention
144 147 50       322 if ( exists $cols{$name} ) {
145 0         0 my $idx = 1;
146              
147 0         0 $idx++ while exists $cols{"${name}_${idx}"};
148 0         0 $name = "${name}_${idx}";
149             }
150              
151             # fix up header to track name change
152 147 50       320 if ( $name ne lc $oname ) {
153 0 0       0 if ( defined( my $item = $hdr->itembyname( "TTYPE$coln" ) ) ) {
154 0         0 $item->value( uc $name );
155             }
156             else {
157 0         0 $hdr->insert(
158             -1,
159             Astro::FITS::Header::Item->new(
160             Keyword => "TTYPE$coln",
161             Value => uc $name,
162             Comment => 'Label for field',
163             Type => 'string'
164             ) );
165             }
166             }
167              
168             # we don't care about a column if it wasn't requested (if any
169             # were requested)
170             next
171             if exists $del_cols{$name}
172 147 100 100     645 || ( @req_cols && !exists $req_cols{$name} );
      100        
173 116         271 $req_cols{$name}++;
174              
175             # preset fields used as arguments to CFITSIO as that doesn't seem
176             # to auto-vivify them
177             my $col = $cols{$name}
178 116         233 = { map { $_ => undef } qw/ btype repeat width naxes btype / };
  580         1261  
179              
180 116         306 $col->{n} = $coln;
181 116         234 $col->{name} = $name;
182              
183              
184             $fptr->get_eqcoltype( $coln, $col->{btype}, $col->{repeat},
185 116         466 $col->{width}, $status );
186              
187             # momentarily read into a Perl array, rather than a piddle
188 116         1797 $fptr->perlyunpacking( 1 );
189 116         507 $fptr->read_tdim( $coln, my $naxis, $col->{naxes} = [], $status );
190 116         4802 $fptr->perlyunpacking( 0 );
191              
192             # figure out what sort of piddle to store the data in
193 116         224 $col->{ptype} = undef;
194              
195             # user specified piddle type?
196 116 100 66     488 if ( exists $user_types{$name} || exists $opt{defdtype} ) {
197 10   33     78 my $type = delete $user_types{$name} || $opt{defdtype};
198              
199             # bit columns are so special
200 10 100 33     107 if ( TBIT == $col->{btype} ) {
    100          
    50          
201             # this results in one piddle byte per bit
202 2 50 0     20 if ( $type =~ /logical/ ) {
    0 0        
    0          
203 2         8 $col->{ptype} = byte;
204 2         9 $col->{ctype} = TBIT;
205             }
206             elsif ( !UNIVERSAL::isa( $type, 'PDL::Type' ) ) {
207 0         0 croak(
208             "unrecognized user specified type for column '$name'" );
209             }
210             elsif ( $type != byte && $type != ushort && $type != long ) {
211 0         0 croak(
212             "bit column type must be byte, ushort, long, or the string 'logical'\n"
213             );
214             }
215             else {
216 0         0 $col->{ptype} = $type;
217 0         0 $col->{ctype} = TBYTE;
218             }
219             }
220              
221             elsif ( !UNIVERSAL::isa( $type, 'PDL::Type' ) ) {
222 2         302 croak( "unrecognized user specified type for column '$name'" );
223             }
224             elsif ($col->{btype} == TLOGICAL
225             || $col->{btype} == TSTRING )
226             {
227 0         0 carp(
228             "ignoring user specified type for column '$name': either LOGICAL, STRING"
229             );
230             }
231             else {
232 6         132 $col->{ptype} = $type;
233             }
234              
235             }
236              
237             # user didn't set it? TBIT is still so special; all handling is done below
238 114 100 100     313 if ( TBIT != $col->{btype} && !defined $col->{ptype} ) {
239 102         586 eval { $col->{ptype} = fits2pdl_coltype( $col->{btype} ); };
  102         290  
240 102 50       245 croak( "column $col->{name}: $@\n" )
241             if $@;
242             }
243              
244              
245             # create the storage area
246              
247             # note that we have to match the PDL storage type to the closest
248             # CFITSIO type, based primarily on size.
249              
250             # strings get read into Perl variables
251 114 100       325 if ( TSTRING == $col->{btype} ) {
252 1         7 $col->{data} = [];
253              
254             # not meaningful
255 1         2 $col->{ctype} = undef;
256             }
257              
258             else {
259              
260 113         434 my $code = '';
261              
262             # if this is a bit column, and the user hasn't specified that
263             # "logical" piddles be used, create a dense map
264 113 100 66     196 if ( TBIT == $col->{btype}
      100        
265             && !( defined $col->{ctype} && TBIT == $col->{ctype} ) )
266             {
267 4         25 $code = map_bits( $col );
268             }
269              
270             else {
271             # simplify data layout if this is truly a 1D data set (else
272             # PDL will create a ( 1 x N ) piddle, which is unexpected.
273             # can't get rid of singleton dimensions if this is a n > 1 dim
274             # data set
275             $col->{naxes} = []
276 109 100 100     465 if @{ $col->{naxes} } == 1 && 1 == $col->{naxes}[0];
  109         478  
277              
278              
279 109 100       327 if ( $col->{btype} == TLOGICAL() ) {
    100          
280 1         5 $col->{ctype} = TLOGICAL();
281             }
282              
283             # ctype may have beend defined above; make sure we don't overwrite it.
284             elsif ( !defined $col->{ctype} ) {
285 106         574 $col->{ctype} = pdl2cfitsio( $col->{ptype} );
286             }
287              
288             # shape of temporary is same as shape of final
289 109         239 $col->{tmpnaxes} = $col->{naxes};
290              
291             # same repeat count as final
292 109         193 $col->{tmprepeat} = $col->{repeat};
293              
294             # set up formats for destination and source slices to copy
295             # from temp to final destination
296 109         166 $col->{dst_slice} = ':,' x @{ $col->{naxes} } . '%d:%d';
  109         319  
297 109         156 $col->{src_slice} = ':,' x @{ $col->{naxes} } . '0:%d';
  109         252  
298              
299              
300 109         187 $code = q/ my ( $col, $start, $nrows ) = @_;
301             my $dest = sprintf($col->{dst_slice}, $start,
302             $start + $nrows - 1);
303             my $src = sprintf($col->{src_slice}, $nrows - 1);
304             (my $t = $col->{data}->slice($dest)) .= $col->{tmppdl}->slice($src);
305             /;
306             }
307              
308 113         17421 eval '$col->{dataxfer} = sub { ' . $code . '}'; ## no critic(ProhibitStringyEval)
309 113 50       370 croak( "internal error in generating dataxfer code: $@\n" )
310             if $@;
311              
312             # create final and temp piddles.
313             $col->{data}
314             = $nrows
315 113 100       390 ? PDL->new_from_specification( $col->{ptype}, @{ $col->{naxes} },
  76         366  
316             $nrows )
317             : PDL->null;
318              
319             # shape of temporary storage for this piddle.
320             $col->{tmpshape}
321 113         3628 = join( ",", $col->{ptype}, @{ $col->{tmpnaxes} }, $ninc );
  113         402  
322              
323             # reuse tmppdls
324             $tmppdl{ $col->{tmpshape} } = (
325             $ninc
326             ? PDL->new_from_specification( $col->{ptype},
327 34         111 @{ $col->{tmpnaxes} }, $ninc )
328             : PDL->null
329 113 100       949 ) unless defined $tmppdl{ $col->{tmpshape} };
    100          
330              
331 113         1307 $col->{tmppdl} = $tmppdl{ $col->{tmpshape} };
332              
333              
334             # How to handle null pixels. A nullval of zero signals CFITSIO to
335             # ignore null pixels
336             $col->{nullval}
337             = exists $opt{nullval} ? $opt{nullval}
338             : $PDL::Bad::Status ? my_badvalue( $col->{ptype} )
339 113 50       458 : 0;
    50          
340 113         3125 $col->{anynul} = 0;
341             }
342              
343             # grab extra column information if requested
344 114 100       383 if ( $opt{retinfo} ) {
345 11         32 $col->{retinfo}{hdr} = {};
346              
347 11         165 for my $item ( $hdr->itembyname( qr/T\D+$col->{n}$/i ) ) {
348 30         1081 $item->keyword =~ /(.*?)\d+$/;
349 30         250 $col->{retinfo}{hdr}{ lc $1 } = $item->value;
350             }
351              
352 11         91 $col->{retinfo}{idx} = $col->{n};
353             }
354              
355             }
356              
357             # now, complain about extra parameters
358             {
359 25         51 my @notfound = grep { !$req_cols{$_} } keys %req_cols;
  25         102  
  114         232  
360 25 50       78 croak( "requested column(s) not in file: ", join( ", ", @notfound ) )
361             if @notfound;
362              
363 25 100       203 croak( "user specified type(s) for columns not in file: ",
364             join( ", ", keys %user_types ), "\n" )
365             if keys %user_types;
366             }
367              
368             # construct final list of columns to be read in, either from the
369             # list the user provided, or from those in the file (sorted by
370             # column number).
371             @cols
372             = @req_cols
373             ? @cols{@req_cols}
374 24 100       124 : sort { $a->{n} <=> $b->{n} } values %cols;
  208         306  
375              
376              
377             # scalar context, more than one column returned? doesn't make sense,
378             # does it?
379             # test for this early, as it may be an expensive mistake...
380 24 100 100     357 croak(
381             "rdfitsTable called in scalar context, but it's to read more than one column?\n"
382             ) if !wantarray() && @cols > 1;
383              
384             # create masks if we'll be row filtering
385 22         51 my ( $good_mask, $tmp_good_mask, $ngood );
386              
387 22 100 100     125 if ( $nrows && $opt{rfilter} ) {
388 4         17 $good_mask = ones( byte, $nrows );
389 4         472 $tmp_good_mask = ones( byte, $ninc );
390 4         239 $ngood = 0;
391             }
392              
393             # start status output
394             # prepare for status updates
395 22         42 my $progress;
396 22 50       67 if ( defined $opt{status} ) {
397 0         0 require Astro::FITS::CFITSIO::Simple::PrintStatus;
398 0         0 eval {
399             $progress
400             = Astro::FITS::CFITSIO::Simple::PrintStatus->new( $opt{status},
401 0         0 $nrows );
402             };
403 0 0       0 croak( $@ ) if $@;
404             }
405              
406              
407 22 50       58 $progress->start() if $progress;
408              
409 22         41 my $next_update = 0;
410 22         39 my $rows_done = 0;
411 22         72 while ( $rows_done < $nrows ) {
412              
413 258 50 33     581 $next_update = $progress->update( $rows_done )
414             if $progress && $rows_done >= $next_update;
415              
416 258         431 my $rows_this_time = $nrows - $rows_done;
417 258 100       567 $rows_this_time = $ninc if $rows_this_time > $ninc;
418              
419             # row filter
420 258 100       550 if ( $opt{rfilter} ) {
421 61         89 my $tmp_ngood = 0;
422             $fptr->find_rows(
423             $opt{rfilter},
424             $rows_done + 1,
425             $rows_this_time,
426             $tmp_ngood,
427 61         109 ${ $tmp_good_mask->get_dataref },
  61         398  
428             $status = "error filtering rows: rfilter = '$opt{rfilter}'"
429             );
430 61         4685 $tmp_good_mask->upd_data;
431              
432             (
433 61         233 my $t = $good_mask->mslice(
434             [ $rows_done, $rows_done + $rows_this_time - 1 ] )
435             ) .= $tmp_good_mask->mslice( [ 0, $rows_this_time - 1 ] );
436              
437 61         4132 $ngood += $tmp_ngood;
438              
439 61 100       381 $tmp_ngood > 0
440             or $rows_done += $rows_this_time,
441             next;
442             }
443              
444 228         421 for my $col ( @cols ) {
445              
446             # beware of empty repeat fields
447 829 50       1911 next unless $col->{repeat};
448              
449 829 50       1954 if ( TSTRING != $col->{btype} ) {
450              
451             $fptr->read_col(
452             $col->{ctype}, $col->{n},
453             $rows_done + 1, 1,
454             $col->{tmprepeat} * $rows_this_time, $col->{nullval},
455 829         4556 ${ $col->{tmppdl}->get_dataref }, $col->{anynul},
456 829         4036 $status = "error reading FITS data"
457             );
458              
459 829         23242 $col->{tmppdl}->upd_data;
460              
461             # transfer the data to the final piddle
462 829         21878 $col->{dataxfer}->( $col, $rows_done, $rows_this_time );
463 829 50       48891 $col->{data}->badflag( $col->{anynul} ) if $PDL::Bad::Status;
464              
465             }
466             else { # string type
467 0         0 my $tmp = [];
468 0         0 $fptr->read_col( TSTRING, $col->{n}, $rows_done + 1,
469             1, $rows_this_time, 0, $tmp, undef,
470             $status = "error reading FITS data",
471             );
472 0         0 push @{ $col->{data} }, @$tmp;
  0         0  
473             }
474              
475             }
476 228         628 $rows_done += $rows_this_time;
477              
478             }
479              
480 22 100 100     143 if ( $nrows && $opt{rfilter} ) {
481              
482 4         17 my $good_index = which( $good_mask );
483              
484 4         704 for my $col ( @cols ) {
485              
486             # beware of empty repeat fields
487 4 50       17 next unless $col->{repeat};
488              
489 4 50       14 if ( TSTRING != $col->{btype} ) {
490             $col->{data} = $col->{data}
491 4         25 ->dice( ( 'X' ) x @{ $col->{naxes} }, which( $good_mask ) );
  4         15  
492             }
493             else { # string type
494 0         0 @{ $col->{data} } = @{ $col->{data} }[ $good_index->list ];
  0         0  
  0         0  
495             }
496             }
497             }
498              
499              
500             # it's all done
501 22 50 33     833 $progress->update( $nrows )
502             if $progress && $nrows >= $next_update;
503              
504 22 50       55 $progress->finish()
505             if $progress;
506              
507             # how shall i return the data? let me count the ways...
508 22 100       78 if ( $opt{retinfo} ) {
509             # gotta put the data into the retinfo structure.
510             # it's safer to do that here, as we have reassigned
511             # $col->{data} above.
512 3         8 my %retvals;
513 3         8 foreach ( @cols ) {
514 11         18 $_->{retinfo}{data} = $_->{data};
515 11         26 $retvals{ $_->{name} } = $_->{retinfo};
516             }
517              
518 3 50       10 $retvals{_hdr} = $hdr if $opt{rethdr};
519 3         178 return %retvals;
520             }
521              
522 19 100       59 if ( $opt{rethash} ) {
523 10         33 my %retvals = map { $_->{name} => $_->{data} } @cols;
  70         218  
524 10 50       42 $retvals{_hdr} = $hdr if $opt{rethdr};
525 10         1057 return %retvals;
526             }
527              
528             # just return the data in the order they were requested.
529 9 100       36 if ( wantarray() ) {
530 4         13 my @retvals = map { $_->{data} } @cols;
  16         32  
531 4 50       13 unshift @retvals, $hdr if $opt{rethdr};
532 4         230 return @retvals;
533             }
534              
535             # if we're called in a scalar context, and there's but one column,
536             # return the column directly. always stick in the header, as a freebee
537 5 50       32 if ( 1 == @cols ) {
538 5         10 my $pdl = $cols[0]->{data};
539 5         29 tie my %hdr, 'Astro::FITS::Header', $hdr;
540 5         80 $pdl->sethdr( \%hdr );
541 5         214 return $pdl;
542             }
543              
544             # scalar context, more than one column returned? doesn't make sense,
545             # does it? we've tested for this before, but it doesn't hurt to stick
546             # it here to remind us.
547              
548             croak(
549 0         0 "rdfitsTable called in scalar context, but it read more than one column?\n"
550             );
551              
552             }
553              
554             # map a BIT column onto the best fit pdl type. this stores the
555             # bits as densely as possible.
556             sub map_bits {
557 4     4 0 9 my ( $col ) = @_;
558              
559             # we're not reading bit columns into boolean vectors (i.e. each
560             # piddle element is one bit). we do a bit of soft shoe to first
561             # read the bit columns as bytes into the temp array and then
562             # bitwise or them into the final piddle
563              
564             # if the user hasn't specified the final piddle type the
565             # special code paths above ensure that $col->{ptype} is still
566             # undefined. in this case we try to find the best sized PDL
567             # type for the FITS element size, where the latter is the
568             # first element in the tdim array (which will be the column
569             # repeat value if TDIMn isn't given).
570              
571             # the number of bytes needed to hold the number of bits. round up.
572 4         26 my $nbytes = POSIX::ceil( $col->{naxes}[0] / 8 );
573              
574 4 50       10 unless ( defined $col->{ptype} ) {
575             # fall back to using bytes
576 4         9 $col->{ptype} = byte;
577              
578             # find the smallest PDL type that will hold an element of the data
579 4         18 for my $type ( byte, ushort, long ) # no longlong yet
580             {
581 8 100       56 next unless PDL::Core::howbig( $type->enum ) == $nbytes;
582 3         28 $col->{ptype} = $type;
583 3         5 last;
584             }
585             }
586              
587             # the number of integral piddles required to hold a single element
588             my $npiddle
589 4         14 = POSIX::ceil( $nbytes / PDL::Core::howbig( $col->{ptype}->enum ) );
590              
591             # adjust to reflect the fact that the "repeat" count is no
592             # longer in bits.
593 4         26 $col->{naxes}[0] = $npiddle;
594 4 100       9 shift @{ $col->{naxes} } if $npiddle == 1;
  3         7  
595              
596             # simplify data layout if this is truly a 1D data set (else
597             # PDL will create a ( 1 x N ) piddle, which is unexpected.
598             # can't get rid of singleton dimensions if this is a n > 1 dim
599             # data set
600             $col->{naxes} = []
601 4 50 66     5 if @{ $col->{naxes} } == 1 && 1 == $col->{naxes}[0];
  4         16  
602              
603             # recalculate repeat value
604 4         8 $col->{repeat} = 1;
605 4         6 $col->{repeat} *= $_ foreach @{ $col->{naxes} };
  4         9  
606              
607             # temp piddle type is same as final piddle, as we may have to
608             # shift bits, and we don't want them to shift off of the
609             # element
610             $col->{ctype} = pdl2cfitsio( $col->{ptype} )
611 4 50       16 unless defined $col->{ctype};
612              
613             # shape of temporary storage for this piddle. we rework
614             # $col->{naxes} which now is in terms of $col->{ptype}, not in
615             # bits. we want it in bytes, as that's the smallest chunk of
616             # bits CFITSIO will give us
617 4         6 my @naxes = ( 1, @{ $col->{naxes} } );
  4         16  
618 4         11 $naxes[0] = PDL::Core::howbig( $col->{ptype}->enum );
619              
620 4         26 $col->{tmpnaxes} = \@naxes;
621              
622             # up the repeat count to handle the fact we're reading in bytes
623 4         5 $col->{tmprepeat} = 1;
624 4         9 $col->{tmprepeat} *= $_ foreach @naxes;
625              
626             # generate subroutine to copy from temp to final
627 4         7 my $code = '';
628 4         6 $code = q/ my ( $col, $start, $nrows ) = @_;
629             my $dst = $col->{data}->dummy(0);
630             my $src = $col->{tmppdl};
631             /;
632              
633             my $dst = join( '',
634 4         5 '$dst->mslice([],', '[],' x ( @{ $col->{naxes} } ),
  4         12  
635             '[$start,$start+$nrows-1])' );
636              
637              
638 4 100       8 if ( $col->{tmpnaxes}[0] > 1 ) {
639 1         4 $code .= "$dst .= 0;\n";
640              
641 1         3 for my $pidx ( 0 .. $col->{tmpnaxes}[0] - 1 ) {
642             my $src = join( '',
643             '$src->mslice([', $pidx, '],',
644 4         33 '[],' x ( @{ $col->{tmpnaxes} } - 1 ),
  4         11  
645             '[0,$nrows-1]) << ',
646             8 * $pidx );
647              
648 4         10 $code .= "$dst |= $src;\n";
649             }
650             }
651             else {
652             my $src = join( '',
653 3         5 '$src->mslice([0],', '[],' x ( @{ $col->{tmpnaxes} } - 1 ),
  3         7  
654             '[0,$nrows-1])' );
655              
656 3         10 $code .= "$dst .= $src;\n";
657             }
658              
659 4         9 $code;
660             }
661              
662              
663              
664             # quick and dirty validation for the status option
665             sub validate_status {
666             # scalar (boolean)
667 0 0 0 0 0   !ref $_[0]
      0        
      0        
      0        
668              
669             # object with appropriate methods
670             || ( blessed( $_[0] ) && $_[0]->can( 'print' ) && $_[0]->can( 'flush' ) )
671              
672             # filehandle
673             || 'GLOB' eq ref $_[0]
674              
675             # subroutine
676             || 'CODE' eq ref $_[0];
677             }
678              
679             #
680             # This file is part of Astro-FITS-CFITSIO-Simple
681             #
682             # This software is Copyright (c) 2008 by Smithsonian Astrophysical Observatory.
683             #
684             # This is free software, licensed under:
685             #
686             # The GNU General Public License, Version 3, June 2007
687             #
688              
689             1;
690              
691             __END__