view release on metacpan or  search on metacpan

lib/Astro/FITS/CFITSIO/Simple/Table.pm  view on Meta::CPAN

use Params::Validate qw/ :all /;

use Carp;

use POSIX ();
use Scalar::Util qw/blessed/;
use PDL;
use PDL::Core qw[ byte ushort long ];

use Astro::FITS::CFITSIO qw/ :constants /;
use Astro::FITS::CFITSIO::CheckStatus;
use Astro::FITS::CFITSIO::Simple::PDL qw/ :all /;
use Astro::FITS::Header;
use Astro::FITS::Header::CFITSIO;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = (
    'all' => [ qw(
          _rdfitsTable
        ) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(

);

our $VERSION = '0.20';

# this must be called ONLY from rdfits.  it makes assumptions about
# the validity of arguments that have been verified by rdfits.

sub _rdfitsTable {

    my $opts = 'HASH' eq ref $_[-1] ? pop : {};

    # first arg is fitsfilePtr
    # second is cleanup object; must keep around until we're done,
    # so it'll cleanup at the correct time.
    my $fptr = shift;

    croak( "column names must be scalars\n" ) if grep { ref $_ } @_;

    my @req_cols = map { lc $_ } @_;


    my %opt = validate_with(
        params         => [$opts],
        normalize_keys => sub { lc $_[0] },
        spec           => {
            nullval  => { type => SCALAR,          optional => 1 },
            rfilter  => { type => SCALAR,          optional => 1 },
            dtypes   => { type => HASHREF,         optional => 1 },
            defdtype => { isa  => qw[ PDL::Type ], optional => 1 },
            ninc     => { type => SCALAR,          optional => 1 },
            rethash  => { type => SCALAR,          default  => 0 },
            retinfo  => { type => SCALAR,          default  => 0 },
            rethdr   => { type => SCALAR,          default  => 0 },
            status   => {
                callbacks => {
                    "boolean, filehandle, subroutine, or object" =>
                      \&validate_status
                },
                optional => 1
            },
        } );

    # data structure describing the columns
    my %cols;

    # final list of columns (not column names!)
    my @cols;

    # CFITSIO status variable
    tie my $status, 'Astro::FITS::CFITSIO::CheckStatus';

    # normalize column names for user specified types.
    my %user_types
      = map { lc( $_ ) => $opt{dtypes}{$_} } keys %{ $opt{dtypes} };


    # see if we're to delete columns
    my @del_cols
      = map { ( my $col = $_ ) =~ s/-//; $col } grep { /^-/ } @req_cols;

    # if columns are to be deleted, can't have any other things in the list
    die( "can't mix -col and col specifictions in list of columns\n" )
      if @del_cols && @del_cols != @req_cols;

    @req_cols = ()
      if @del_cols;

    my %del_cols = map { ( $_ => 1 ) } @del_cols;


    # hash of requested column names (if any); used to track
    # non-existant columns
    my %req_cols = map { ( $_ => 0 ) } @req_cols;

    # by default return a hash of data unless columns are requested
    # (del_cols don't count)
    $opt{rethash} = 1 unless @req_cols || $opt{retinfo};

    # grab header
    my $hdr = Astro::FITS::Header::CFITSIO->new( fitsID => $fptr );

    # grab the number of columns and rows in the HDU
    $fptr->get_num_cols( my $ncols, $status );
    $fptr->get_num_rows( my $nrows, $status );

    # this is the number of rows to process at one time.
    my $ninc = $opt{ninc};
    $ninc or $fptr->get_rowsize( $ninc, $status );
    $ninc = $nrows if $nrows < $ninc;

    # use transfer buffers until we can figure out how to read chunks
    # directly into the final piddles. These are indexed off of the
    # shape of the piddle so that we can reuse them and save memory.
    my %tmppdl;