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__ |