File Coverage

blib/lib/Astro/FITS/CFITSIO/Simple.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Astro::FITS::CFITSIO::Simple;

use 5.008002;
use strict;
use warnings;

require Exporter;

use Params::Validate qw/ :all /;

use Carp;

use PDL;

use Astro::FITS::CFITSIO qw/ :constants /;
use Astro::FITS::CFITSIO::CheckStatus;
use Astro::FITS::CFITSIO::Simple::Table qw/ :all /;
use Astro::FITS::CFITSIO::Simple::Image qw/ :all /;


our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Astro::FITS::CFITSIO::Table ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
  rdfits
) ] );

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

our @EXPORT = qw(

);

our $VERSION = '0.18';

# cheap and dirty clean up object so that we can maintain
# return contexts in rdfits and its delegates by having
# cleanup done during object destruction
{
  package Astro::FITS::CFITSIO::Simple::Cleanup;

  sub new { my $class = shift; bless {@_}, $class };
  sub set { $_[0]->{$_[1]} = $_[2] };
  sub DESTROY{ my $s = shift;
	       tie my $status, 'Astro::FITS::CFITSIO::CheckStatus';
	       $s->{fptr}->perlyunpacking($s->{packing})
		 if defined $s->{packing};
	       $s->{fptr}->movabs_hdu( $s->{hdunum}, undef, $status)
		 if defined $s->{hdunum} }
}



# HDU types we recognize
our %HDUType = (
		img    => IMAGE_HDU,
		image  => IMAGE_HDU,
		binary => BINARY_TBL,
		bintbl => BINARY_TBL,
		ascii  => ASCII_TBL,
		any    => ANY_HDU,
		table  => undef, 	# the CFITSIO flags aren't really bits
	       );

sub validHDUTYPE { exists $HDUType{lc $_[0]} }
sub validHDUNUM  { $_[0] =~ /^\d+$/ && $_[0] > 0 }



# these are the Params::Validate specifications for rdfits
# they are specified separately here, so that parameters
# for _rdfitsTable and _rdfitsImage can be split out
# from the main option hash

our %rdfits_spec =
  (
   extname  => { type => SCALAR,  optional => 1 },
   extver   => { type => SCALAR,
		 depends => 'extname',
		 default  => 0 },
   hdunum   => { type => SCALAR,
		 callbacks => { 'illegal HDUNUM' =>
				\&validHDUNUM,
			      },
		 optional => 1 },
   hdutype  => { type => SCALAR,
		 callbacks => { 'illegal HDU type' =>
				\&validHDUTYPE,
			      },
		 default => 'any',
		 optional => 1 },
   resethdu => { type => SCALAR,  default  => 0 },
  );

sub rdfits
{

  # strip off the options hash
  my $opts = 'HASH' eq ref $_[-1] ? pop : {};

  # first arg is fitsfilePtr or filename
  my $input = shift;

  croak( "input must be a fitsfilePtr or a file name\n" )
    unless defined $input &&
      ( UNIVERSAL::isa( $input, 'fitsfilePtr' ) || ! ref $input );


  # rdfits is a dispatch routine; we need to filter out the options
  # for the delegates (and vice versa).  final argument validation
  # is done by the the delegates

  # shallow copy, then delete non-rdfits options.
  my %rdfits_opts = %{$opts};
  delete @rdfits_opts{ grep { !exists $rdfits_spec{ lc($_) } }
			 keys %rdfits_opts };

  # shallow copy, then delete rdfits options
  my %delegate_opts = %{$opts};
  delete @delegate_opts{ keys %rdfits_opts };

  # if there are additional arguments, guess that we're being
  # asked for some columns, and set the requested HDUTYPE to table
  $rdfits_opts{hdutype} = 'table' if @_;

  # validate arguments
  my %opt =
    validate_with( params => [ \%rdfits_opts ],
		   normalize_keys => sub{ lc $_[0] },
		   spec => \%rdfits_spec );



  # CFITSIO file pointer
  my $fptr;

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

  my $cleanup;

  # get CFITSIO file pointer
  if (UNIVERSAL::isa( $input, 'fitsfilePtr'))
  {

    $fptr = $input;

    $cleanup = new Astro::FITS::CFITSIO::Simple::Cleanup
      ( fptr => $fptr, packing => $fptr->perlyunpacking );

    if ( $opt{resethdu} )
    {
      $fptr->get_hdu_num( my $hdunum );
      $cleanup->set( hdunum => $hdunum );
    }

  }
  else
  {
    $fptr = Astro::FITS::CFITSIO::open_file($input, READONLY,
			    $status = "could not open FITS file '$input'");
  }

  # we're not unpacking;
  $fptr->perlyunpacking(0);

  # read in all of the extensions
  if ( $opt{slurp} )
  {
    croak( "slurp not yet implemented!\n" );
  }

  # read in just one
  else
  {
    my $hdutype;

    # HDU specified by name
    if ( exists $opt{extname} )
    {
      $fptr->movnam_hdu(ANY_HDU, $opt{extname}, $opt{extver},
	$status = "could not move to HDU '$opt{extname}:$opt{extver}'");

      $fptr->get_hdu_type( $hdutype, $status );

      croak( "requested extension does not match requested HDU type\n" )
	unless match_hdutype( $opt{hdutype}, $hdutype );
    }

    # HDU specified by number?
    elsif ( exists $opt{hdunum} )
    {
      $fptr->movabs_hdu( $opt{hdunum}, $hdutype, $status );

      croak( "requested extension does not match requested HDU type\n" )
	unless match_hdutype( $opt{hdutype}, $hdutype );
    }

    # first recognizeable one
    else
    {
      # lazy; let CheckStatus do the work.
      eval {
	until ( $status )
	{
	  $fptr->get_hdu_type($hdutype, $status);

	  # check that we're in an actual image, i.e. NAXIS != 0
	  if ( IMAGE_HDU == $hdutype )
	  {
	    $fptr->get_img_dim( my $naxis, $status );
	    next unless $naxis;
	  }
	  last if match_hdutype( $opt{hdutype}, $hdutype );

	}
	continue
	{
	  $fptr->movrel_hdu( 1, $hdutype, $status );
	}
      };

      # ran off end of file
      croak( "unable to find a matching HDU to read\n" )
	if BAD_HDU_NUM == $status;

      # all other errors
      croak $@ if $@;
    }

    # update args. $cleanup must be passed so that it will be destroyed
    # after the delegate routine has finished.
    unshift @_, $fptr, $cleanup;

    # add the options for the delegate
    push @_, \%delegate_opts;

    # dispatch. we use the dispatch goto here to keep croak's etc. at the
    # correct level and to maintain the calling context.
    BINARY_TBL == $hdutype || ASCII_TBL == $hdutype
      and goto &_rdfitsTable;

    IMAGE_HDU == $hdutype
      and goto &_rdfitsImage;

    croak( "internal error. bizarre hdutype = $hdutype\n" );
  }

  croak( "internal error; can't get here from there\n" );

}

# a thin front end for reading in a table

sub rdfitstbl
{
  # make shallow copy of passed options hash (or create one)
  my %opt = 'HASH' eq ref $_[-1] ? %{pop @_} : ();

  # force the HDU to match a table
  $opt{hdutype} = 'table';

  # read only one HDU
  delete $opt{slurp};

  # make sure only the input file is in there.
  croak( "too many arguments to rdfitstbl\n" )
    if @_ > 1;

  # attach our new options hash
  push @_, \%opt;

  # do the whole shebang; pretend we were never here.
  goto &rdfits;
}

# a thin front end for reading in an image

sub rdfitsimg
{
  # make shallow copy of passed options hash (or create one)
  my %opt = 'HASH' eq ref $_[-1] ? %{pop @_} : ();

  # force the HDU to match a table
  $opt{hdutype} = 'image';

  # read only one HDU
  delete $opt{slurp};

  # attach our new options hash
  push @_, \%opt;

  # do the whole shebang; pretend we were never here.
  goto &rdfits;
}

sub match_hdutype
{
  my ( $req, $actual ) = @_;

  return (BINARY_TBL == $actual || ASCII_TBL  == $actual )
    if 'table' eq $req;

  my $reqtype = $HDUType{ $req };

  return 1 if ANY_HDU == $reqtype;

  return 1 if $reqtype == $actual;


  0;
}


1;