File Coverage

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

Criterion	Covered	Total	%
statement	19	38	50.0
branch	0	4	0.0
condition	0	3	0.0
subroutine	7	9	77.7
pod			n/a
total	26	54	48.1

# --8<--8<--8<--8<--
#
# Copyright (C) 2008 Smithsonian Astrophysical Observatory
#
# This file is part of Astro::FITS::CFITSIO::Utils
#
# Astro::FITS::CFITSIO::Utils is free software: you can redistribute
# it and/or modify it under the terms of the GNU General Public
# License as published by the Free Software Foundation, either version
# 3 of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see .
#
# -->8-->8-->8-->8--

package Astro::FITS::CFITSIO::Utils;

use 5.006;
use strict;
use warnings;

use Carp;

our $VERSION = '0.13';

use Carp;

use Astro::FITS::Header::Item;

{
  package Astro::FITS::CFITSIO::Utils::Item;

  our @ISA = qw( Astro::FITS::Header::Item );

  sub new
  {
    my $class = shift;
    $class = ref $class || $class;

    my ($keyw, $value );
    # clean up input list, removing things that the superclass won't
    # understand. must be a better way to do this.
    my %args;
    my @o_args = @_;
    my @args;

    while(  ($keyw, $value ) = splice(@o_args, 0, 2 ) )
    {
      if ( $keyw =~ /^(?:hdu_num|)$/i )
      {
	$args{lc $keyw} = $value;
      }
      else
      {
	push @args, $keyw, $value;
      }
    }

    my $self = $class->SUPER::new( @args );

    # handle the attributes that we know about
    $self->$keyw( $value )
      while( ( $keyw, $value ) = each %args );

    return $self;
  }

  sub hdu_num
  {
    my $self = shift;
    if (@_) {
      $self->{hdu_num} = uc(shift);
    }
    return $self->{hdu_num};
  }
}

use Astro::FITS::Header::CFITSIO;
use Astro::FITS::CFITSIO
  qw[ READONLY CASEINSEN
      ANY_HDU ASCII_TBL BINARY_TBL
      BAD_HDU_NUM END_OF_FILE
   ];
use Astro::FITS::CFITSIO::CheckStatus;
use Params::Validate qw( validate_with :types );

require Exporter;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw(
keypar
keyval
colkeys
croak_status
) ] );

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


# Preloaded methods go here.

# this is just a convenience wrapper around keypar
sub keyval
{
  my $opts = (@_ && 'HASH' eq ref $_[-1]) ? pop @_ : undef;

  keypar( @_, { defined $opts ? %$opts : () , Value => 1 } );
}



#  $k1 = keypar( $file, $kw1 );
#   implicit OnePerHDU = 1, Accumulate = 0
#   $k1 = first matching card

#  @k =  keypar( $file, $kw1 );
#   implicit OnePerHDU = 0, Accumulate = 1
#   @k = all matching cards

# ( $k1, $k2 ) = keypar( $file, [ $kw1, $kw2 ] );
#   implicit OnePerHDU = 1, Accumulate = 0
#   $k1 = first matching card
#   $k2 = first matching card

# $k = keypar( $file, [$kw1, $kw2] )
#   illegal



sub keypar
{
  my $file = shift;
  my $opts = (@_ && 'HASH' eq ref $_[-1]) ? pop @_ : undef;

  @_ == 1
    or croak( __PACKAGE__, "::keypar: incorrect number of arguments\n" );

  # set up defaults. they change to make things DWIM
  my %opt = ( Accumulate => ref $_[0] || ! wantarray() ? 0 : 1,
	      OnePerHDU  => ref $_[0] || ! wantarray() ? 1 : 0,
	      Value => 0,
	       $opts ? %$opts : ()
	     );

  $opt{CurrentHDU} = 0
    unless defined $opt{CurrentHDU} || $file =~ /\[/;

  my $keyword;

  if ( 'ARRAY' eq ref $_[0] )
  {
    $keyword = [ map { uc($_) } @{$_[0]} ];
  }

  elsif ( ! ref $keyword )
  {
    # don't do more work than the caller requests
    unless ( wantarray() )
    {
      $opt{Accumulate} = 0;
      $opt{OnePerHDU} = 1;
    }
    $keyword = [ uc $_[0] ];
  }
  else
  {
    croak( __PACKAGE__, "::keypar: illegal type for keyword\n" );
  }


  my %keywords = map { $_ => [] } @$keyword;

  # are we passed a pointer to an open file?
  my $file_is_open = eval { $file->isa( 'fitsfilePtr' ) };
  my $fptr;

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

  if ( $file_is_open )
  {
      $fptr = $file;
  }

  else
  {
      $fptr = Astro::FITS::CFITSIO::open_file
	( $file, READONLY,
	  $status = __PACKAGE__ . "::keypar: error reading $file: " );
  }

  $fptr->get_hdu_num( my $init_hdu_num );
  $fptr->movabs_hdu( 1, undef, $status );
  $fptr->get_hdu_num( my $ext );

  # number of keywords found. used to short circuit search if
  # Accumulate == 0
  my $nfound = 0;

  for ( ;; $ext++ )
  {
    my $hdr = Astro::FITS::Header::CFITSIO->new( fitsID => $fptr,
						 ReadOnly => 1 );

    # loop over keywords
    while( my ( $keyw, $found ) = each %keywords )
    {
      # ignore this keyword if we've found a match and Accumulate
      # hasn't been set.
      next if @$found && ! $opt{Accumulate};

      my @newfound = $hdr->itembyname( $keyw );
      if ( @newfound )
      {
	$#newfound = 0 if $opt{OnePerHDU};
	foreach ( @newfound )
	{
	  my $item = Astro::FITS::CFITSIO::Utils::Item->new( Card => $_->card, HDU_NUM => $ext);
	  push @$found,
	    $opt{Value} && defined $item ? $item->value : $item;
	}
	$nfound ++;
      }
    }

    last if $opt{CurrentHDU} ||
      ! $opt{Accumulate} && $nfound == @$keyword;

    $fptr->movrel_hdu( 1, undef, my $lstatus = 0);

    last if $lstatus == BAD_HDU_NUM || $lstatus == END_OF_FILE;
    croak_status( $lstatus );
  }

  # done mucking about in the file; if it was an existing opened file
  # return to the initial HDU
  $fptr->movabs_hdu( $init_hdu_num, my $dummy, $status )
    if $file_is_open;

  # if passed an array ref for $keyword, prepare to handle multiple
  # keywords
  if ( ref $_[0] )
  {
    my @found;

    # a single value per keyword.  return list of scalars
    if ( $opt{OnePerHDU} && !$opt{Accumulate} )
    {
      @found = map { @{$_}[0] } @keywords{@$keyword};
    }

    # multiple values per keyword.  return list of arrayrefs.
    else
    {
      @found = @keywords{@$keyword};
    }
    return wantarray ? @found : \@found ;
  }

  else
  {
    my $found = $keywords{@{$keyword}[0]};

    return wantarray ? @$found : @$found ? @{$found}[0] : undef;
  }

  # NOT REACHED

}

sub colkeys {

    my $file = shift;

    my %opt = validate_with ( params => \@_,
                              spec => {
                                       extname => { type => SCALAR,
                                                    optional => 1 },
                                       extver  => { type => SCALAR,
                                                    regex => qr/^\d+$/,
                                                    optional => 1,
                                                    depends => [ 'extname' ]
                                                  }
                                      },
                              normalize_keys => sub { lc $_[0] },
                            );

    # are we passed a pointer to an open file?
    my $file_is_open = eval { $file->isa( 'fitsfilePtr' ) };
    my $fptr;
    my $init_hdu_num;

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

    if ( $file_is_open )
    {
	$fptr = $file;
	$fptr->get_hdu_num( $init_hdu_num );
    }
    else
    {
	$error = "Error reading $file: ";
	$fptr = Astro::FITS::CFITSIO::open_file( $file, READONLY, $error );
    }

    # move to specified HDU
    if ( $opt{extname} )
    {
        $opt{extver} ||= 0;
        my $extname = $opt{extname} . ($opt{extver} ? $opt{extver} : '');

        $error = "$file does not contain an extension of $extname";
        $fptr->movnam_hdu( ANY_HDU, $opt{extname}, $opt{extver}, $error );

        $fptr->get_hdu_type( my $hdutype, $error );

        croak( "$file\[$extname] is not a table\n")
          if $hdutype != ASCII_TBL and $hdutype != BINARY_TBL;
    }

    # find the first Table HDU
    else
    {
        my $status;

        while( 1 )
        {
            $error = "$file has no table extension";
            $fptr->movrel_hdu( 1, my $hdutype, $error );
            last if $hdutype == ASCII_TBL || $hdutype == BINARY_TBL;
        }
    }

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

    $fptr->get_num_cols( my $ncols, $error );

    my %colkeys;
    for my $coln (1..$ncols) {

        my %info;

        $fptr->get_colname( CASEINSEN, $coln, my $oname, undef, $error );
        my $name = lc $oname;

        # blank name!  can't have that.  just # number 'em after the
        # actual column position.
        $name = "col_$coln" if  '' eq $name;

        if ( exists $colkeys{$name} )
        {
            my $idx = 1;

            $idx++ while exists $colkeys{ "${name}_${idx}" };
            $name = "${name}_${idx}";
        }

        for my $item ( grep { $_ !~ /^NAXIS/ }
		       $hdr->itembyname( qr/\D+$coln([a-z])?$/i ) )
        {
            my $key = lc join('',
			      grep { defined }
			      $item->keyword =~ /(.*)$coln(.*)$/ );
            $info{$key} = $item->value;
        }

        $colkeys{$name} = { hdr => \%info,
                           idx => $coln };
    }

    # done mucking about in the file; if it was an existing opened file
    # return to the initial HDU
    $fptr->movabs_hdu( $init_hdu_num, undef, $error )
      if $file_is_open;

    return %colkeys;
}

sub croak_status {
  my $s = shift;

  if ($s)
  {
    Astro::FITS::CFITSIO::fits_get_errstatus($s, my $txt);

    local $Carp::CarpLevel = $Carp::CarpLevel + 1;
    croak @_, "CFITSIO Error: $txt\n";
  }
}



1;
__END__