Util::SimpleFITS (version 0.0)

package Util::SimpleFITS;
########################################################################
#
# DESCRIPTION: Lean and mean FITS interface
#
# HISTORY: $Log: SimpleFITS.pm,v $
# HISTORY: Revision 1.8  2005/09/17 16:19:47  apsop
# HISTORY: Load TBIT columns as strings.
# HISTORY:
# HISTORY: Revision 1.7  2005/08/30 14:33:13  apsop
# HISTORY: Change documentation comments to standard format.
# HISTORY:
# HISTORY: Revision 1.6  2005/08/16 21:20:00  apsop
# HISTORY: Added a method to load an entire table into a list of hash refs with
# HISTORY: keys corresponding to the column names.
# HISTORY:
# HISTORY: Revision 1.5  2005/07/06 20:36:55  apsop
# HISTORY: Implemented BAT position refinement.
# HISTORY:
# HISTORY: Revision 1.4  2005/05/13 19:36:52  apsop
# HISTORY: Allow user to specify output variable for status, nhdu calls.
# HISTORY:
# HISTORY: Revision 1.3  2005/04/01 14:52:44  apsop
# HISTORY: Update header comment section
# HISTORY:
#
# HISTORY: Revision 1.2  2004/11/16 14:15:15  apsop
# HISTORY: Added reopen and wrappers for open modes.
#
# HISTORY: Revision 1.1  2004/11/09 19:07:31  apsop
# HISTORY: Adding BAT pipeline support modules.
#
#
# VERSION: 0.0
#
###########################################################################
use strict;

use Astro::FITS::CFITSIO qw(:longnames :constants);



sub open {
    my ($first,$inspec) = @_;
    my ($fits,$mode, $modestr, $filename);

    my $self = bless {};

    my $status = 0;
    if ($inspec =~ m/^([+<>]*)([^+<>].*)/) {
	$modestr = $1 || '<';
	$filename = $2;

	if ($modestr eq ">" || ($modestr eq "+<" && ! -f $filename)) {
	    $fits = Astro::FITS::CFITSIO::create_file($filename,$status);
	    
	} else {
	    if ($modestr eq "<") {
		$mode = READONLY;
	    } elsif ($modestr eq "+<") {
		$mode = READWRITE;
	    } else {
		die("bad inspec [$inspec]");
	    }
	    $fits = Astro::FITS::CFITSIO::open_file("$filename",$mode,$status);
#	    print "fits=$fits filename=$filename mode=$mode status=$status\n";
	}
    }
    
    $self->{fits} = $fits;
    $self->{status} = $status;

    return $self;
}


sub readonly
{
	my ($first, $path) = @_;
	return $first->open("<$path");
}

sub create
{
	my ($first, $path) = @_;
	return $first->open(">$path");
}

sub update
{
	my ($first, $path) = @_;
	return $first->open("+<$path");
}


sub reopen
{
	my ($self, $inspec) = @_;

	my $fits = $self->open($inspec);

	if ($fits->{status}) {
		$self->{status} = $fits->{status};
	}
	else {
		$self->close;
		%$self = %$fits;
	}

	return $self;
}


sub close {
    my ($self) = @_;
    my ($fits);

    return 0 unless ($self);
    $fits = $self->{fits};
    return $self unless ($fits);

    my $status = 0;

    $fits->close_file($status);
    undef $self->{fits};
    return $self;
}

sub status {
    my ($self) = @_;
    return NULL_INPUT_PTR unless ($self);
    if (@_ >= 2) {
        $_[1] = $self->{status};
        return $self;
    }

    return $self->{status};
}

sub setstatus {
    my ($self,$value) = @_;

    return 0 unless ($self);
    $self->{status} = $value;

    return $self;
}

sub handle { 
    my ($self) = @_;
    return 0 unless ($self);
    return $self->{fits};
}

sub nhdu {
    my ($self) = @_;
    my ($nhdu);

    return 0 unless ($self);
    my $fits = $self->{fits};
    return $self unless ($fits);

    my $status = $self->{status};

    $fits->get_num_hdus($nhdu,$status);

    $self->{status} = $status;
    if (@_ >= 2) {
        $_[1] = $nhdu;
        return $self;
    }

    return $nhdu;
}

sub move {
    my ($self,$hdu) = @_;

    return 0 unless ($self);
    my $fits = $self->{fits};
    return $self unless ($fits);

    my $status = $self->{status};
    if ($status) { return $self; }

    if ($hdu =~ m/^[-+][0-9]+$/) {
	$fits->movrel_hdu($hdu,undef,$status);
    } elsif ($hdu =~ m/^[0-9]+$/) {
	$fits->movabs_hdu($hdu,undef,$status);
    } else {
	$fits->movnam_hdu(ANY_HDU,$hdu,0,$status);
    }

    $self->{status} = $status;
    return $self;
}

sub readheader {
    my ($self,$header) = @_;
    my ($fits, $status, $value, $comment, $dtype, $type);
    
    return 0 unless ($self);
    $fits = $self->{fits};
    return $self unless ($fits);

    $status = $self->{status};
    if ($status) { return $self; }

    ($header, $status) = $fits->read_header();
    $self->{status} = $status;

    $_[1] = $header;
    
    return $self;
}

sub readkey {
    my ($self,$keyname) = @_;
    my ($fits, $status, $value, $comment, $dtype, $type);
    
    return 0 unless ($self);
    $fits = $self->{fits};
    return $self unless ($fits);

    $status = $self->{status};
    if ($status) { return $self; }

    if ($_[4]) {
	$type = $_[4];
    } else {
	$fits->read_keyword($keyname,$value,$comment,$status);
	Astro::FITS::CFITSIO::fits_get_keytype($value,$dtype,$status);
	$type = TSTRING;
	if ($dtype eq 'L')    { $type = TLOGICAL; } 
	elsif ($dtype eq 'I') { $type = TINT; }
	elsif ($dtype eq 'F') { $type = TDOUBLE; }
    }
    $fits->read_key($type,$keyname,$value,$comment,$status);
    $self->{status} = $status;

    if ($#_ <= 0) {
	return $value;
    }

    $_[2] = $value;
    $_[3] = $comment;
	     
    return $self;
}

sub vtype {
    my ($val) = @_;
    my ($strval);
    
    $strval = "$val";
    if ($strval =~ m/^[-+]?[0-9]+$/) {
	return TLONG;
    } elsif ($strval =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/) {
	# m/^[-+]?[0-9.]+[eE]?([-+][0-9]+)?/     my old one
	return TDOUBLE;
    }
    return TSTRING;

}

sub writekey {
    my ($self,$keyname,$value) = @_;
    my ($fits, $status, $comment, $type);

    return 0 unless ($self);
    $fits = $self->{fits};
    return $self unless ($fits);
    $status = $self->{status};
    
    if ($status) { return $self; }

    $comment = 0;
    if ($_[3]) { $comment = "$_[3]"; }
    if ($_[4]) { $type = $_[4]; } else { $type = vtype($value); }

    $fits->update_key($type,$keyname,$value,$comment,$status);

    $self->{status} = $status;

    return $self;
}


sub readcol {
    my ($self,$column,$type,$rrows) = @_;
    my ($fits, $status, $colnum, $nrows);
    my ($typecode, $repeat, $width, $r, $nel, $rowstart, $data, $comment);
    my @rows;

    return 0 unless ($self);
    $fits = $self->{fits};
    return $self unless ($fits);
    $status = $self->{status};
    
    if ($status) { return $self; }

    if ($column =~ m/^[0-9]$/) {
	$colnum = $column;
    } else {
	$fits->get_colnum(CASEINSEN,$column,$colnum,$status);
    }

    $fits->get_num_rows($nrows,$status) unless $status;
    $fits->get_coltype($colnum,$typecode,$repeat,$width,$status) unless $status;
    if ($status) {
	$self->{status} = $status;
	return $self;
    }

    if ($typecode == TSTRING) { $repeat /= $width; }
    if (!defined($type)) { $type = $typecode; }

    $r = ref($rrows);
    if ($r eq "SCALAR") {
	@rows = ($$rrows,$$rrows);
    } elsif ($r eq "ARRAY") {
	@rows = @$rrows;
	if ($#rows == -1) { @rows = (1, $nrows); }
	if ($#rows ==  0) { @rows = ($rows[0], $rows[0]); }
    } elsif ($rrows) {
	@rows = ($rrows, $rrows);
    } else {
	@rows = (1, $nrows);
    }

    $rowstart = $rows[0];
    $nel = ($rows[1] - $rows[0] + 1)*$repeat;

	my $passedArray = UNIVERSAL::isa($_[4], 'ARRAY');
	if ($passedArray) {
		$data = $_[4];
	}

    $fits->read_col($type,$colnum,$rowstart,1,$nel,undef,$data,undef,$status);
    $self->{status} = $status;

    if ($#_ == (3-1)) {
	return @$data;
    }
if (not $passedArray) {
    $_[4] = $data;
}

    return $self;
}


sub writecol {

    my ($self,$column,$options,$data) = @_;
    my ($rrows,$type);
    my ($fits, $status, $colnum, $nrows);
    my ($typecode, $repeat, $width, $r, $nel, $rowstart, $comment);
    my @rows;

    return 0 unless ($self);
    $fits = $self->{fits};
    return $self unless ($fits);
    $status = $self->{status};
    
    if ($status) { return $self; }

    if ($column =~ m/^[0-9]$/) {
	$colnum = $column;
    } else {
	$fits->get_colnum(CASEINSEN,$column,$colnum,$status);
    }

    $fits->get_num_rows($nrows,$status) unless $status;
    $fits->get_coltype($colnum,$typecode,$repeat,$width,$status) unless $status;
    if ($status) {
	$self->{status} = $status;
	return $self;
    }

    if ($typecode == TSTRING) { $repeat /= $width; }
    $type = $options->{type};
    if (!defined($options->{type})) { $type = $typecode; }

    $rrows = $options->{rows};
    $rrows = [] unless($rrows);

    $r = ref($rrows);
    if ($r eq "SCALAR") {
	@rows = ($$rrows,$$rrows);
    } elsif ($r eq "ARRAY") {
	@rows = @$rrows;
	if ($#rows == -1) { @rows = (1, $nrows); }
	if ($#rows ==  0) { @rows = ($rows[0], $rows[0]); }
    } elsif ($rrows) {
	@rows = ($rrows, $rrows);
    } else {
	@rows = (1, $nrows);
    }

    $rowstart = $rows[0];
    $nel = ($rows[1] - $rows[0] + 1)*$repeat;

    $fits->write_col($type,$colnum,$rowstart,1,$nel,$data,$status);
    $self->{status} = $status;

    return $self;
}


sub parsekeys {
    my ($arg) = @_;

    if (ref($arg) eq "SCALAR") {
	return ("$$arg",undef,TSTRING);
    } elsif (ref($arg) eq "ARRAY") {
	return ("$$arg[0]", $$arg[1], $$arg[2]);
    } else {
	return ("$arg",undef,TSTRING);
    }
}

sub createtab {
    my ($self,$extname) = @_;
    my ($fits, $status, $colnum, $nrows);
    my @rows;

    return 0 unless ($self);
    $fits = $self->{fits};
    return $self unless ($fits);
    $status = $self->{status};
    
    if ($status) { return $self; }

    $fits->create_tbl(BINARY_TBL,0,0,undef,undef,undef,$extname,$status);
    $self->{status} = $status;

    return $self;
}


sub insertcol {
    my ($self,$colkeys,$column) = @_;
    my ($fits, $status, $colnum, $ncols);
    my ($ttype,$type,$comment,$tform,$value);
    my ($typecode, $repeat, $width, $r, $nel, $rowstart);
    my @rows;
	my %defcomments;

    return 0 unless ($self);
    $defcomments{TUNIT} = "physical unit of field";
    $defcomments{TSCAL} = "data scale";
    $defcomments{TZERO} = "data offset";
    $defcomments{TNULL} = "data null value";
    $defcomments{TDIM} = "Array dimensions";
    $defcomments{TDMIN} = "Minimum column data value";
    $defcomments{TDMAX} = "Maximum column data value";
    $defcomments{TLMIN} = "Minimum legal value";
    $defcomments{TLMAX} = "Maximum legal value";

    $fits = $self->{fits};
    return $self unless ($fits);
    $status = $self->{status};

    if ($status) { return $self; }
    if (!defined($colkeys)) {return $self; }
    if (!defined($$colkeys{TTYPE}) || !defined($$colkeys{TFORM})) { 
	$self->{status} = -1;
	return $self;
    }

    $fits->get_num_cols($ncols,$status);

    if (!defined($column)) {
	$colnum = $ncols+1;
    } elsif ($column =~ m/^[0-9]$/) {
	$colnum = $column;
    } else {
	$fits->get_colnum(CASEINSEN,$column,$colnum,$status);
    }
    
    if ($status) {
	$self->{status} = $status;
	return $self;
    }
    
    ($ttype,$comment) = parsekeys($$colkeys{TTYPE});
    if (! $ttype ) { 
	$self->{status} = -1;
	return $self;
    }
    ($tform) = parsekeys($$colkeys{TFORM});
    $self->{status} = $status;

    $fits->insert_col($colnum,$ttype,$tform,$status);
    if ($comment) { $self->writekey("TTYPE$colnum",$ttype,$comment,TSTRING); }
    foreach my $key (keys %$colkeys) {
	if ($key ne "TTYPE" && $key ne "TFORM") {
	    undef $type; undef $comment;

	    ($value,$comment,$type) = parsekeys($$colkeys{$key});
	    if (!defined($type)) { $type = vtype($value); }
	    if (!defined($comment) && $defcomments{$key}) { 
		$comment = $defcomments{$key};
	    }

	    $self->writekey("$key$colnum",$value,$comment,$type);
	}
    }

    return $self;
}


sub loadTable
{
	my ($self, $dataref, $tableref) = @_;

	return 0 unless ($self);

	my $fits = $self->{fits};
	return $self unless ($fits);

	my $status = $self->{status};

	my $nrows;
	my $ncols;

	$fits->get_num_rows($nrows, $status) unless $status;
	$fits->get_num_cols($ncols, $status) unless $status;

	my @column;
	for (my $i = 1; not $status and $i <= $ncols; ++$i) {
		my $colname;
		my $comment;
		my $type;
		my $repeat;
		my $width;
		my @data;
		$fits->read_key_str("TTYPE$i", $colname, $comment, $status);
		$colname =~ s/^'//;
		$colname =~ s/\s*'$//;

		$fits->get_coltype($i, $type, $repeat, $width, $status)
				unless $status;

		my $readstr = $type == TSTRING || $type == TBIT;
		my $nelem = $readstr ? $nrows : $nrows * $repeat;
		my $nulls;
		if ($status) {
		}
		elsif ($readstr) {
			$fits->read_col_str($i, 1, 1, $nelem, 0,
					\@data, $nulls, $status)
		}
		else {
			$fits->read_col($type, $i, 1, 1, $nelem, 0,
					\@data, $nulls, $status)
		}

		if (not $status and $type == TBIT) {
			@data = map { substr($_, 0, $repeat) } @data;
		}

		my %column = (
			index => $i,
			name => uc($colname),
			type => $type,
			data => \@data,
		);

		push(@column, \%column);
	}

	if ($status) {
		$self->{status} = $status;
	}
	else {
		for (my $i = 0; $i < $nrows; ++$i) {
			my %record = map { $_->{name} => $_->{data}[$i] } @column;
			push(@$dataref, \%record);
		}
	}

	return $self;
}


1;