File Coverage

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

Criterion	Covered	Total	%
statement	143	154	92.8
branch	56	70	80.0
condition	27	44	61.3
subroutine	16	18	88.8
pod	4	4	100.0
total	246	290	84.8

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

# ABSTRACT: FITS utility routines

use v5.10;
use strict;
use warnings;

our $VERSION = '0.14';

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

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

    use parent '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 SCALAR );

use parent 'Exporter';

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

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


sub _croak {
    require Carp;
    goto &croak;
}

# 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 {
        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 = Astro::FITS::Header::CFITSIO->new( 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;

#
# This file is part of Astro-FITS-CFITSIO-Utils
#
# This software is Copyright (c) 2023 by Smithsonian Astrophysical Observatory.
#
# This is free software, licensed under:
#
#   The GNU General Public License, Version 3, June 2007
#

__END__