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


line stmt bran cond sub pod time code
1             package Text::LAS::Parser;
2              
3 1     1   19821 use 5;
  1         4  
  1         41  
4 1     1   4 use strict;
  1         1  
  1         27  
5 1     1   4 use warnings;
  1         6  
  1         88  
6              
7             require Exporter;
8              
9             our @ISA = qw(Exporter);
10             our @EXPORT = qw(
11             get_info_in_non_A_sections
12             read_Section_A
13             );
14              
15             our $VERSION = '0.01';
16              
17 1     1   915 use IO::Handle;
  1         6931  
  1         50  
18 1     1   7 use Scalar::Util qw( looks_like_number );
  1         1  
  1         94  
19 1     1   4 use Carp;
  1         2  
  1         1713  
20              
21             sub new {
22 1     1 1 190 my ( $class, $source ) = @_;
23 1 50       4 $source or croak 'Null source';
24 1         3 my $this = { 'source' => $source };
25 1         4 bless $this;
26 1 50       5 $this->_parse_downto_section_A_beginning_flag()
27             and return $this;
28             }
29              
30             sub _parse_downto_section_A_beginning_flag {
31 1     1   1 my ( $this ) = @_;
32              
33 1 50       14 $$this{'source'}->opened()
34             or croak "Not opened: ",$$this{'source'};
35              
36 1         37 while( my $line = $$this{'source'}->getline() ) {
37 23         692 $line =~ s/[\r\n]*$//;
38 23 100 66     79 if ( $line =~ /^\s*\#(.*)$/
      66        
39             && ( ! &_section_now_reading( $this ) || &_section_now_reading( $this ) !~ /^A/ ) ) {
40 11         19 &_process_comment( $this, $1 );
41 11         231 next;
42             }
43 12 100       33 if ( $line =~ /^\s*\~(.*)$/ ) {
44 6 100       13 if ( &_process_flag( $this, $1 ) ) {
45 5 100       9 &_section_now_reading( $this ) =~ /^A/ and last;
46             }
47 5         104 next;
48             }
49 6 100 66     14 if ( &_section_now_reading( $this ) && &_section_now_reading( $this ) =~ /^[VWPC]/ ) {
50 5 50       27 $line =~ /^\s*([^\s\.\:]*)\s*\.([^\s\:]*)\s+(.*)\:([^\:]*)$/
51             or croak 'Corrupt line in Section '.&_section_now_reading( $this ).": $line";
52 5         10 &_process_VWPC_line( $this, $1, $2, $3, $4 );
53 5         112 next;
54             }
55 1         30 print STDERR "Skipping Line: $line\n";
56             }
57              
58 1 50       5 &_section_already_read( $this, 'W' ) or croak 'Section W is mandate';
59 1 50       4 &_section_already_read( $this, 'C' ) or croak 'Section C is mandate';
60 1 50       3 &_section_already_read( $this, 'A' ) or croak 'Section A is mandate';
61              
62 1 50       3 substr( &_section_now_reading( $this ), 0, 1 ) eq 'A'
63             or die "Maybe a bug: should at the beginning of the Section A now";
64              
65 1         4 &_check_non_data( $this );
66              
67 1         10 return 1;
68             }
69              
70             sub get_info_in_non_A_sections {
71 0     0 1 0 my ( $this, $section ) = @_;
72 0         0 foreach my $k ( keys %$this ) {
73 0 0       0 $k =~ /^Section $section/ or next;
74 0         0 return @{$$this{$k}};
  0         0  
75             }
76             }
77              
78             sub _section_now_reading {
79 59     59   61 my $this = shift;
80 59 100       51 $#{$$this{'sections_read'}} < 0 and return;
  59         148  
81 56         61 return ${$$this{'sections_read'}}[$#{$$this{'sections_read'}}];
  56         308  
  56         67  
82             }
83              
84             sub _section_already_read {
85 12     12   19 my ( $this, $section ) = @_;
86 12         13 $section = substr( $section, 0, 1 );
87 12         19 foreach my $s (@{$$this{'sections_read'}}) {
  12         25  
88 30 100       101 substr( $s, 0, 1 ) eq $section
89             and return 1;
90             }
91 9         32 return;
92             }
93              
94             sub _process_comment {
95 12     12   23 my ( $this, $comment ) = @_;
96 12         213 print STDERR "Skipping Comment: $comment\n"; #
97             }
98              
99             sub _process_flag {
100 6     6   9 my ( $this, $flag ) = @_;
101             # print STDERR "Flag: $flag\n"; #
102 6 100       18 if ( $flag !~ /^[VWPCOA]/ ) {
103 1         3 &_process_comment( $this, $flag );
104 1         2 return 0;
105             }
106 5 50 66     7 ! &_section_now_reading( $this ) && substr( $flag, 0, 1 ) ne 'V'
107             and croak "The first section must be V: $flag";
108 5 50       10 &_section_already_read( $this, 'A' )
109             and croak "Another section after Section A: $flag";
110 5 50 66     10 &_section_now_reading( $this ) && &_section_already_read( $this, substr( $flag, 0, 1 ) )
111             and croak "Section must present only once: $flag";
112 5         7 push( @{$$this{'sections_read'}}, $flag );
  5         10  
113 5         11 print STDERR 'Entered Section: ',&_section_now_reading( $this ),"\n"; #
114 5         25 return 1;
115             }
116              
117             sub _process_VWPC_line {
118 5     5   15 my ( $this, $mnem, $units, $data, $description ) = @_;
119 5         6 push( @{$$this{'Section '.substr( &_section_now_reading( $this ), 0, 1)}},
  5         12  
120             [ $mnem, $units, $data, $description ] );
121             }
122              
123             sub _check_non_data {
124 1     1   3 my $this = shift;
125              
126 1         2 foreach my $v ( @{$$this{'Section V'}} ) {
  1         3  
127 2 100       9 $$v[0] eq 'VERS'
128             and &_check_LAS_version( $this, $$v[1], $$v[2], $$v[3] );
129 2 100       7 $$v[0] eq 'WRAP'
130             and &_check_wrap_around_mode( $this, $$v[1], $$v[2], $$v[3] );
131             }
132 1 50       10 $$this{'LAS VERSION'} or croak 'LAS version is not specified';
133 1 50       4 $$this{'WRAP AROUND MODE'} or croak 'Wrap around mode is not specified';
134              
135 1         1 foreach my $w ( @{$$this{'Section W'}} ) {
  1         2  
136 1 50       6 $$w[0] eq 'NULL'
137             and &_check_null_values( $this, $$w[1], $$w[2], $$w[3] );
138             }
139 1 50       3 $$this{'NULL VALUE'} or croak 'NULL value is not specified';
140              
141 1         2 my $not_first = 0;
142 1         1 foreach my $c ( @{$$this{'Section C'}} ) {
  1         2  
143 2 0 66     10 ! $not_first && $$c[0] ne 'DEPT' && $$c[0] ne 'DEPTH' && $$c[0] ne 'TIME'
      33        
      33        
144             and croak 'The first channel must be either DEPT, DEPTH or TIME: ',$$c[0];
145 2         3 $not_first = 1;
146 2 50       13 $$c[3] eq '' and croak 'No curve description';
147             }
148             }
149              
150             sub _check_LAS_version {
151 1     1   3 my ( $this, $units, $data, $description ) = @_;
152 1 50       6 $data =~ /2\.0\s*/
153             or croak "Can read LAS Version 2.0 only: $data";
154 1         3 $$this{'LAS VERSION'} = $data;
155             }
156              
157             sub _check_wrap_around_mode {
158 1     1   3 my ( $this, $units, $data, $description ) = @_;
159 1 50 33     9 $data =~ /YES\s*/ || $data =~ /NO\s*/
160             or croak "Unknown wrap around mode: $data :$description";
161 1 50       3 $data =~ /YES\s*/
162             and croak "Can read one line per depth step only";
163 1         3 $$this{'WRAP AROUND MODE'} = $data;
164             }
165              
166             sub _check_null_values {
167 1     1   3 my ( $this, $units, $data, $description ) = @_;
168 1         15 $$this{'NULL VALUE'} = $data;
169             }
170              
171             sub read_Section_A {
172 3     3 1 6 my ( $this, $null_replacement ) = @_;
173 3 100       69 my $line = $$this{'source'}->getline() or return 0;
174 2         66 $line =~ s/[\r\n]*$//;
175 2 50 33     9 $line =~ /^\s*\~(.*)$/ and &_process_flag( $this, $1 ) and return 0;
176 2         7 return &_process_A_line( $this, $null_replacement, $line );
177             }
178              
179             sub _process_A_line {
180 2     2   4 my ( $this, $null_replacement, $line ) = @_;
181 2         7 my @columns = split( /\s+/, $line );
182 2 50       13 $columns[0] eq '' and shift( @columns );
183 2 50       5 $#columns < 0 and croak 'Blank line in Section A';
184 2 50       3 $#columns == $#{$$this{'Section C'}}
  2         6  
185             or croak 'Less columns than channels';
186 2         7 for( my $i = 0; $i <= $#columns; $i++ ) {
187 4 100 66     38 looks_like_number( $columns[$i] ) && $columns[$i] == $$this{'NULL VALUE'}
188             and $columns[$i] = $null_replacement;
189             }
190 2         11 return \@columns;
191             }
192              
193             1;
194             __END__