File Coverage

blib/lib/Astro/Funtools/Parse.pm

Criterion	Covered	Total	%
statement	127	129	98.4
branch	42	58	72.4
condition			n/a
subroutine	13	13	100.0
pod	4	4	100.0
total	186	204	91.1

package Astro::Funtools::Parse;

use strict;
use warnings;

use Carp;
use IO::File;

require Exporter;

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::Parse::Funtools ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
	parse_funcnts
        parse_funcnts_file
	parse_funhist
	parse_funhist_file
) ] );

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

our @EXPORT = qw(

);

our $VERSION = '0.08';

use Data::LineBuffer;


# Preloaded methods go here.

sub parse_funhist_file
{
  my $file = shift;
  my $fh = new IO::File $file
    or croak( __PACKAGE__, "::parse_funhist_file: unable to open $file\n" );

  parse_funhist( $fh );
}

sub parse_funhist
{
  my $what = shift;

  my %results;

  my $src = new Data::LineBuffer $what
    or croak( __PACKAGE__, "parse_funcnts: something wrong with argument\n");

  my $header = _parse_header( $src );

  if ( exists $header->{_TOP}{'min,max,bins'} )
  {
    my ( $min, $max, $bins ) = split( ' ', $header->{_TOP}{'min,max,bins'} );
    delete $header->{_TOP}{'min,max,bins'};
    @{$header->{_TOP}}{qw( min max bins) } = ( $min, $max, $bins );
  }

  # grab the first thing; it's a table
  my $table = _parse_table( $src );

  ( $header->{_TOP}, $table );
}

sub parse_funcnts_file
{
  my $file = shift;
  my $fh = new IO::File $file
    or croak( __PACKAGE__, "::parse_funcnts_file: unable to open $file\n" );

  parse_funcnts( $fh );
}


sub parse_funcnts
{
  my $what = shift;

  my @results;

  my $src = new Data::LineBuffer $what
    or croak( __PACKAGE__, "parse_funcnts: something wrong with argument\n");

  LINE: while ( 1 )
  {
    my %results;

    $results{hdr} = _parse_header( $src );

    last unless %{$results{hdr}};

    # grab the first thing; it's a table
    my $ln = $src->pos;
    my $table = _parse_table( $src );

    # is it a summed background-subtracted table?
    if ( grep { 'upto' eq $_ } @{$table->{names}} )
    {
      $results{sum_bkgd_sub}{table} = $table;
      # next thing is the real background subtracted table, then
      $ln = $src->pos;
      $results{bkgd_sub}{table} = _parse_table( $src );

      # but we'll check on that!
      croak( __PACKAGE__,
  	   "::parse_funcnts: line $ln: expected a background-subtracted ",
  	   "table but didn't find one!\n" )
        unless grep { 'reg' eq $_ }
                     @{$results{bkgd_sub}{table}->{names}};
    }

    # nope, must be a background-subtracted table
    else
    {
      $results{bkgd_sub}{table} = $table;
      croak( __PACKAGE__,
  	   "::parse_funcnts: line $ln: expected a background-subtracted ",
  	   "table but didn't find one!\n" )
        unless grep { 'reg' eq $_ }
                     @{$table->{names}};
    }

    # ok, now we're looking for regions, source and possibly background
    # each region has a table after it.

    $results{source}{regions}  = _parse_funcnts_regions( $src );

    $results{source}{table} = _parse_table( $src );

    # if there's a region left, it'll be the background

    my $regions = _parse_funcnts_regions( $src );
    if ( %$regions )
    {
      if ( @{$regions->{regions}} )
      {
        $results{bkgd}{regions} = $regions;
        $results{bkgd}{table}   = _parse_table( $src );
      }
      _skip_past_formfeed( $src );
    }
    push @results, \%results;
  }
  return wantarray
       ? @results
       : $results[0];
}

sub _skip_past_formfeed
{
  my $src = shift;

  local $_;

  for( my $ln = $src->pos; defined ($_ = $src->get) ; $ln = $src->pos )
  {
    last if /^\f$/;
  }
}


sub _parse_funcnts_regions
{
  my $src = shift;

  local $_;

  my $title;
  my @regions;

  while( defined ($_ = $src->get) )
  {
    return {} if /^\f$/;
    next unless /^#\s+(.*)$/;
    /^#\s+((source|background)_region\(s\))/;
    return unless $_;
    $title = $1;
    last;
  }

  while( defined ($_ = $src->get) )
  {
    last unless /^#\s+(.*)$/;
    push @regions, $1;
  }

  { title => $title, regions => \@regions };
}



sub _parse_header
{
  my $src = shift;

  my %hdr;

  local $_;

  my $key = '_TOP';
  for( my $ln = $src->pos; defined ($_ = $src->get) ; $ln = $src->pos )
  {
    last unless /^\#/;
    if ( /:/ )
    {
      croak( __PACKAGE__,
	     "::_parse_header: line $ln: missing key in header\n" )
	unless defined $key;

      my ( $subkey, $val ) = /^\#\s+(.*):\s+(.*)/;
      $subkey =~ s/\s+$//;
      $subkey =~ s/\s/_/g;
      $val =~ s/\s+$//;
      $hdr{$key}{$subkey} = $val;
    }

    else
    {
      ( $key ) = /^\#\s+(.*)/;
      $key =~ s/\s+$//;
    }
  }

  \%hdr;
}

sub _parse_table
{
  my $src = shift;

  my @records;
  my @comments;
  my @names;

  local $_;

  my $ln;

  # search for start of table.  look for a leading `-'
  # ignore empty lines. anything with a leading `#' is a comment.
  # anything else is the list of column names.
  for( $ln = $src->pos ; defined ( $_ = $src->get ) ; $ln = $src->pos )
  {
    next if /^\s*$/;

    last if /^-+/;

    if ( /^\#(.*)$/ )
    {
      push @comments, $1;
    }

    else
    {
      croak( __PACKAGE__,
	     "::_parse_table: line $ln: more than one set of column headers?\n" )
	     if @names;

      chomp;
      @names = split;
    }
  }

  croak( __PACKAGE__, "::_parse_table: line $ln: no table here!\n" )
    unless defined $_;

  my @widths = map { length($_) } split(' ', $_ );
  croak( __PACKAGE__,
	 "::_parse_table: line $ln: inconsistent number of column names and separators" )
    if @names != @widths;


  # work around extra blank line between header and data
  $_ = $src->get;
  $src->unget( $_ )
    unless /^\s*$/;

  for ( my $ln = $src->pos; defined ($_ = $src->get) ;$ln = $src->pos )
  {
    last if /^\s*$/;

    chomp;
    my @data = split;
    unless ( @data == @names )
    {
      croak( __PACKAGE__,
	   "::_parse_table: line $ln: number of columns and number of data elements differ" )
    }
    my %data;
    @data{@names} = @data;
    push @records, \%data;
  }

  return { comments => \@comments,
	   names => \@names,
	   widths => \@widths,
	   records => \@records };
}


1;
__END__