File Coverage

blib/lib/Text/LAS/Parser.pm

Criterion	Covered	Total	%
statement	113	118	95.7
branch	47	74	63.5
condition	18	33	54.5
subroutine	19	20	95.0
pod	3	3	100.0
total	200	248	80.6

package Text::LAS::Parser;

use 5;
use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);
our @EXPORT = qw(
get_info_in_non_A_sections
read_Section_A
);

our $VERSION = '0.01';

use IO::Handle;
use Scalar::Util qw( looks_like_number );
use Carp;

sub new {
    my ( $class, $source ) = @_;
    $source or croak 'Null source';
    my $this = { 'source' => $source };
    bless $this;
    $this->_parse_downto_section_A_beginning_flag()
	and return $this;
}

sub _parse_downto_section_A_beginning_flag {
    my ( $this ) = @_;

    $$this{'source'}->opened()
	or croak "Not opened: ",$$this{'source'};

    while( my $line = $$this{'source'}->getline() ) {
	$line =~ s/[\r\n]*$//;
	if ( $line =~ /^\s*\#(.*)$/
	     && ( ! &_section_now_reading( $this ) || &_section_now_reading( $this ) !~ /^A/ ) ) {
	    &_process_comment( $this, $1 );
	    next;
	}
	if ( $line =~ /^\s*\~(.*)$/ ) {
	    if ( &_process_flag( $this, $1 ) ) {
		&_section_now_reading( $this ) =~ /^A/ and last;
	    }
	    next;
	}
	if ( &_section_now_reading( $this ) && &_section_now_reading( $this ) =~ /^[VWPC]/ ) {
	    $line =~ /^\s*([^\s\.\:]*)\s*\.([^\s\:]*)\s+(.*)\:([^\:]*)$/
		or croak 'Corrupt line in Section '.&_section_now_reading( $this ).": $line";
	    &_process_VWPC_line( $this, $1, $2, $3, $4 );
	    next;
	}
	print STDERR "Skipping Line: $line\n";
    }

    &_section_already_read( $this, 'W' ) or croak 'Section W is mandate';
    &_section_already_read( $this, 'C' ) or croak 'Section C is mandate';
    &_section_already_read( $this, 'A' ) or croak 'Section A is mandate';

    substr( &_section_now_reading( $this ), 0, 1 ) eq 'A'
	or die "Maybe a bug: should at the beginning of the Section A now";

    &_check_non_data( $this );

    return 1;
}

sub get_info_in_non_A_sections {
    my ( $this, $section ) = @_;
    foreach my $k ( keys %$this ) {
	$k =~ /^Section $section/ or next;
	return @{$$this{$k}};
    }
}

sub _section_now_reading {
    my $this = shift;
    $#{$$this{'sections_read'}} < 0 and return;
    return ${$$this{'sections_read'}}[$#{$$this{'sections_read'}}];
}

sub _section_already_read {
    my ( $this, $section ) = @_;
    $section = substr( $section, 0, 1 );
    foreach my $s (@{$$this{'sections_read'}}) {
	substr( $s, 0, 1 ) eq $section
	    and return 1;
    }
    return;
}

sub _process_comment {
    my ( $this, $comment ) = @_;
    print STDERR "Skipping Comment: $comment\n"; #
}

sub _process_flag {
    my ( $this, $flag ) = @_;
#    print STDERR "Flag: $flag\n"; #
    if ( $flag !~ /^[VWPCOA]/ ) {
	&_process_comment( $this, $flag );
	return 0;
    }
    ! &_section_now_reading( $this ) && substr( $flag, 0, 1 ) ne 'V'
	and croak "The first section must be V: $flag";
    &_section_already_read( $this, 'A' )
	and croak "Another section after Section A: $flag";
    &_section_now_reading( $this ) && &_section_already_read( $this, substr( $flag, 0, 1 ) )
	and croak "Section must present only once: $flag";
    push( @{$$this{'sections_read'}}, $flag );
    print STDERR 'Entered Section: ',&_section_now_reading( $this ),"\n"; #
    return 1;
}

sub _process_VWPC_line {
    my ( $this, $mnem, $units, $data, $description ) = @_;
    push( @{$$this{'Section '.substr( &_section_now_reading( $this ), 0, 1)}},
	  [ $mnem, $units, $data, $description ] );
}

sub _check_non_data {
    my $this = shift;

    foreach my $v ( @{$$this{'Section V'}} ) {
	$$v[0] eq 'VERS'
	    and &_check_LAS_version( $this, $$v[1], $$v[2], $$v[3] );
	$$v[0] eq 'WRAP'
	    and &_check_wrap_around_mode( $this, $$v[1], $$v[2], $$v[3] );
    }
    $$this{'LAS VERSION'} or croak 'LAS version is not specified';
    $$this{'WRAP AROUND MODE'} or croak 'Wrap around mode is not specified';

    foreach my $w ( @{$$this{'Section W'}} ) {
	$$w[0] eq 'NULL'
	    and &_check_null_values( $this, $$w[1], $$w[2], $$w[3] );
    }
    $$this{'NULL VALUE'} or croak 'NULL value is not specified';

    my $not_first = 0;
    foreach my $c ( @{$$this{'Section C'}} ) {
	! $not_first && $$c[0] ne 'DEPT' && $$c[0] ne 'DEPTH' && $$c[0] ne 'TIME'
	    and croak 'The first channel must be either DEPT, DEPTH or TIME: ',$$c[0];
	$not_first = 1;
	$$c[3] eq '' and croak 'No curve description';
    }
}

sub _check_LAS_version {
    my ( $this, $units, $data, $description ) = @_;
    $data =~ /2\.0\s*/
	or croak "Can read LAS Version 2.0 only: $data";
    $$this{'LAS VERSION'} = $data;
}

sub _check_wrap_around_mode {
    my ( $this, $units, $data, $description ) = @_;
    $data =~ /YES\s*/ || $data =~ /NO\s*/
	or croak "Unknown wrap around mode: $data :$description";
    $data =~ /YES\s*/
	and croak "Can read one line per depth step only";
    $$this{'WRAP AROUND MODE'} = $data;
}

sub _check_null_values {
    my ( $this, $units, $data, $description ) = @_;
    $$this{'NULL VALUE'} = $data;
}

sub read_Section_A {
    my ( $this, $null_replacement ) = @_;
    my $line = $$this{'source'}->getline() or return 0;
    $line =~ s/[\r\n]*$//;
    $line =~ /^\s*\~(.*)$/ and &_process_flag( $this, $1 ) and return 0;
    return &_process_A_line( $this, $null_replacement, $line );
}

sub _process_A_line {
    my ( $this, $null_replacement, $line ) = @_;
    my @columns = split( /\s+/, $line );
    $columns[0] eq '' and shift( @columns );
    $#columns < 0 and croak 'Blank line in Section A';
    $#columns == $#{$$this{'Section C'}}
	or croak 'Less columns than channels';
    for( my $i = 0; $i <= $#columns; $i++ ) {
	looks_like_number( $columns[$i] ) && $columns[$i] == $$this{'NULL VALUE'}
	    and $columns[$i] = $null_replacement;
    }
    return \@columns;
}

1;
__END__